perm filename SVLISP.MAC[VLI,LSP] blob
sn#382062 filedate 1978-09-14 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00207 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00015 00002 TITLE VLISP - 10 . 3 : INTERPRETEUR et COMPILATEUR.
C00017 00003 taille standard des zones de tavail.
C00018 00004 registres, constantes, OPDEF et externes FORTRANs.
C00020 00005 bits du RG.
C00023 00006 MACROS
C00027 00007 macros : SKIP & JUMP.
C00031 00008 macros : CONSL
C00033 00009 macros : GETCAR GETCDR PUTCAR PUTCDR UNCONS et freres.
C00035 00010 macros : SETBIT CLRBIT JPBIT JNBIT et freres.
C00037 00011 macros : SAVR BABYL MOVEMM MEXP
C00039 00012 IMPUR STORAGE
C00042 00013 core : impur storage (configurateur) .
C00045 00014 CORE : impur storage (constantes d'init)
C00046 00015 CORE : impur storage (pile) .
C00050 00016 CORE : memoire pour le G.C.
C00052 00017 CORE : impur storage (interrupt) .
C00055 00018 CORE : pour le display DM IRCAM.
C00057 00019 CORE : fonctions standards (TOPLEVEL INPUT OUTPUT DIRECTORY)
C00059 00020 CORE : fonctions standards (FILOP TMPCOR)
C00061 00021 CORE : fonctions standard (LIBRARY CORE RUN GETSPC ...)
C00063 00022 CORE : fonctions d'entree sortie.
C00068 00023 CORE : FORTRAN et DAC.
C00069 00024 MEM OBJET
C00071 00025 MEM OBJ : I/O.
C00073 00026 MEM OBJ : interprete controle et fonctionnelles.
C00075 00027 MEM OBJ : predicats recherche et modification tableaux.
C00078 00028 MEM OBJ : nombres et chaines.
C00082 00029 MEM OBJ : fonctions systeme speciales.
C00084 00030 MEM OBJ : fonctions du LAP et AUTOLOAD.
C00086 00031 Initialisation, Configuration.
C00088 00032 configuration (initialisation des pointeurs)
C00093 00033 configuration (initialisation des zones)
C00095 00034 init GC PATHLIBRARY et depart a chaud.
C00098 00035 configuration (initialisation du systeme d'interruptions).
C00100 00036 (CONFIGURATION init inp outp ....) [NSUBR]
C00103 00037 ↑C intercept + pdl ovfl + arith ovfl
C00106 00038 TRAP GC ET ILL. REF. MEMORY
C00108 00039 interrupt ESCAPE-I
C00112 00040 RESET REENT
C00114 00041 TOP-LEVEL
C00116 00042 GARBAGE-COLLECTING
C00119 00043 G.C. : GARBCOLL (entries)
C00121 00044 G.C. : marquage
C00126 00045 G.C. : edition des statistiques.
C00132 00046 G.C. : MARK
C00135 00047 G.C. : MAKFREE MKSTRG
C00138 00048 - G.C. : MKNUMB MKLITA
C00142 00049 I/O
C00144 00050 I.O. : CONVCS CVSAT
C00146 00051 I.O. : CVATR
C00148 00052 I.O. : CVPPN
C00150 00053 I.O. : GETSPC
C00152 00054 I.O. : INPUT
C00156 00055 I.O. : OUTPUT
C00159 00056 I.O. : FILOP
C00162 00057 I.O. : DIRECTORY
C00166 00058 I.O. : LIBRARY
C00170 00059 I.O. : PATHLIBRARY
C00173 00060 I.O. : RDCORE WRCORE
C00177 00061 I.O. : RUN ALIAS
C00180 00062 I.O. : SHOWIT TMPCOR
C00183 00063 TTY : TYI TYS TYO PPIOT CALLI
C00185 00064 TTY : SETACTABLE TRMOP
C00187 00065 TTY : UPGIOT
C00192 00066 FONCTIONS D'ENTREE
C00195 00067 IN : EOF
C00196 00068 IN : GETCH GETCHV
C00199 00069 IN : RZPNAME READ1
C00202 00070 IN : TRYATOM
C00206 00071 IN : REASTR
C00208 00072 IN : CRATOM
C00211 00073 IN : CRACAR CRASTR CRASTN CRPSTR
C00213 00074 IN : CRANUM CRAZER CRAONE CRAFLT
C00215 00075 IN : $CRANB $CRANP creations nb pour le compilo
C00218 00076 IN : READ READU
C00224 00077 IN : READM MQUOTE MOCTAL
C00227 00078 IN : TEREAD READCH PEEKCH
C00229 00079 IN : IMPLODE
C00233 00080 FONCTIONS DE SORTIE
C00235 00081 OUT : PRBPN
C00237 00082 OUT : PRCHT PRSPAC PRCH et la fonction OUTBUF
C00240 00083 OUT : CONVBD CONVB0 CONVD0
C00243 00084 OUT : CNVFLT CONVNB
C00247 00085 OUT : PRATOM (litatom)
C00249 00086 OUT : PRATOM (nombres et chaines)
C00251 00087 OUT : PRIN1
C00254 00088 OUT : PRIN1 (suite)
C00257 00089 OUT : PRINT PRINTU PRIN1U TERPRI TTAB
C00259 00090 OUT : PRINC SPACES PAGE PRINTLEVEL PRINTLENGTH
C00262 00091 ERREURS
C00264 00092 ERR : messages (ERLC)
C00267 00093 ERR : messages (suite)
C00271 00094 ERR : impression et backtrace.
C00273 00095 ERR : trap des erreurs LISP
C00275 00096 FONCTIONS INTERPRETE
C00277 00097 INTR : RETSYS RETRAC TRACES
C00280 00098 INTR : BIND DBIND
C00283 00099 INTR : UNBIND
C00285 00100 INTR : APPLY
C00287 00101 INTR : APPLY (vrai debut) SELF et APPLYN
C00291 00102 INTR : APPLY lancements super-rapides.
C00293 00103 INTR : APPLY fonctions normales.
C00296 00104 INTR : EVAL
C00298 00105 INTR : EVAL erreur, trace et step.
C00301 00106 INTR : EVAL atomes et formes simples.
C00304 00107 INTR : EVAL lancements super-rapides.
C00308 00108 INTR : EVAL lancement rapide des lambdas.
C00312 00109 INTR : EVAL evaluations des lambdas-expressions normales.
C00317 00110 INTR : EVAL des LAMBDAS tail-recs et co-post-recs.
C00320 00111 INTR : EVAL fonctions normales et tracees.
C00326 00112 INTR : SUBR FSUBR EVEVL MACH
C00328 00113 INTR : evaluations speciales LAMBDA COMMENT POUR ETRACE
C00330 00114 INTR : EVLIS
C00332 00115 INTR : EPROGN PROGN PROG1 PROG2
C00335 00116 FONCTIONS DE CONTROLE
C00338 00117 CTRL : OR AND IF IFN
C00340 00118 CTRL : COND SELECT
C00342 00119 CTRL : SELECTQ
C00345 00120 CTRL : WHILE UNTIL REPEAT
C00347 00121 FONCTIONNELLES
C00349 00122 FNCT : MAPLIST MAPCAR MAPT MAPCT
C00351 00123 FNCT : MAPS MAPSUB MAPST
C00353 00124 FNCT : EVERY SOME ANDF ORF
C00355 00125 PROG + DO FEATURE
C00357 00126 PROG : DO
C00359 00127 PROG : RETURN CYCLE
C00361 00128 PROG : GO GOTO
C00362 00129 PREDICATS
C00364 00130 PRED : EQ NEQ
C00366 00131 PRED : EQUAL NEQUAL
C00368 00132 PRED : SORT SAMEPN
C00370 00133 FONCTIONS SUR LES P-LISTES
C00372 00134 P-L- : PUT
C00375 00135 P-L- : GET
C00377 00136 P-L- : GETL
C00378 00137 P-L- : REMPROP
C00381 00138 DEF : DE DF DG DMI DMO
C00383 00139 DEF : AUTOLOAD DMC
C00385 00140 FONCTIONS DE RECHERCHE
C00387 00141 RECH : MEMQ MEMBER CNTH NTH
C00389 00142 RECH : LAST
C00391 00143 RECH : TYPEP TYPEFN TYPNUMB
C00394 00144 RECH : ASSOC CASSOC ASSQ CASSQ
C00396 00145 STACK : PUSH POP PSTACK
C00399 00146 FONCTIONS DE MODIFICATION
C00401 00147 MODF : RPLACA RPLACD RPLACB NCONC NCONC1 EXCH
C00403 00148 MODF : NEXTL NEWL SMACH ATTACH
C00405 00149 MODF : FREVERSE INCR DECR
C00408 00150 FONCTIONS DE CREATION
C00410 00151 CRAT : LIST LINEAR
C00412 00152 CRAT : SUBST [PAT] AUG 17 1978
C00415 00153 CRAT: SUBLIS [PAT] AUG 14 78
C00416 00154 CRAT : COPY
C00418 00155 CRAT : OBLIST PAIRLIS
C00420 00156 CRAT : DELQ DELETE
C00423 00157 CRAT : REVERSE APPEND APPEND1
C00425 00158 CRAT : EXPLODE ASCII CASCII
C00428 00159 CRAT : GENSYM
C00430 00160 CRAT: LIT [PAT] AUG 16 1978
C00432 00161 ARRAY
C00435 00162 ARRAY : DA
C00439 00163 ARRAY : DIM STOREQ STORE
C00441 00164 ARRAY : LISTARRAY FILLARRAY
C00444 00165 ARRAY : MAPARRAY MAPARRAYQ
C00446 00166 PREDICATS NUMERIQUES
C00448 00167 NUMB : LEZP LZP GEZP GZP ZEROP NEROP EVENP ODDP
C00449 00168 NUMB : EQN NEQN GT GE LT LE DIVP
C00451 00169 NUMB : $PNSUB $LT $LE $GT $GE
C00452 00170 FONCTIONS NUMERIQUES
C00454 00171 NUMER : ADD1 SUB1 MINUS ABS SWAP COMPL
C00455 00172 NUMER : PLUS DIFFER TIMES QUO REM MIN MAX
C00457 00173 NUMER COMPILO : SPLUS SDIFFER STIMES SQUO SREM SMAX SMIN
C00459 00174 NUMER : LOGAND LOGOR LOGXOR LOGSHIFT
C00461 00175 NUMER : BOOLE
C00463 00176 FLOT : ARERR TFL1
C00465 00177 FLOT : TFL2 FIX FLOAT
C00468 00178 FLOT : FADD1 FSUB1 FADD FSUB FTIM
C00470 00179 FLOT : FQUO FREM PUISS
C00472 00180 FLOT : FEQ FNEQ FLE FLT FGE FGT
C00475 00181 FORT : APFORT FSQRT FSIN FCOS
C00477 00182 FORT : FATAN FEXP FLOG FLOG10 RANDOM
C00479 00183 DAC : Toutes les fonctions sur le DAC.
C00481 00184 FONCTIONS SUR LES CHAINES
C00483 00185 STRG : EQSTRING STRINGL CONCAT
C00485 00186 STRG : REVERSTR DUPL
C00487 00187 STRG : SUBSTRING
C00489 00188 STRG : TRANSLATE
C00492 00189 STRG : READSTR
C00493 00190 FONCTIONS SYSTEMES.
C00496 00191 SYS : OTODE TIME
C00498 00192 SYS : DATE VERSION
C00500 00193 STAT : STATB STATC STATW
C00503 00194 STAT : STATT STATUS DE 0 a 29
C00510 00195 STATUS de 30 a 39
C00513 00196 STATUS SPECIAUX DU LAP + COMPIL
C00519 00197 LAP : GETSYMBOL
C00521 00198 LAP : OPCD
C00527 00199 LAP : REGISTER
C00530 00200 LAP : VALAP
C00532 00201 LAP : LOADCODE
C00537 00202 CMPL : :NSUBR :NSUBRP :SBIND :FSBIND
C00540 00203 CMPL : :SBIND1 :SBIND2
C00543 00204 CMPL : :SBIND3 :ESBIND :PRINC1
C00546 00205 CMPL : :$MAPCN :$MAPC1 :$MAPN :$MAP1
C00550 00206 FONCTIONS TRES SPECIALES : DDT BREAK STOP .
C00555 00207 LLIT : fin de l'interprete .
C00556 ENDMK
C⊗;
TITLE VLISP - 10 . 3 : INTERPRETEUR et COMPILATEUR.
COMMENT \
*******************************************************************
Jerome CHAILLOUX 1976 - 1977 - 1978
Universite de PARIS 8
Route de la tourelle
75571 PARIS CEDEX 12
tel : 374 12 50 poste 299
I.R.C.A.M. (Institut de Recherche
et de Coordination Acoustique/Musique)
31 Rue Saint Merri
75004 PARIS
*******************************************************************
\
TWOSEG ; ya 2 segments (HIGH est prevu SHARE)
; ouverture des bibliotheques.
SEARCH JOBDAT,C
; numero de version. VLISP 10 . 3
VLIWHO==5 ; user.
VLIVER==↑D10 ; major version.
VLIMIN==3 ; minor version.
VLIEDT==↑D19 ; edit version.
LOC .JBVER
VRSN. VLI
RELOC
; indicateurs d'assemblages.
%%MTST==0 ; =0 si pas de test des macros.
%%LLIT==0 ; =0 si pas de liste des litteraux.
%IRCAM==0 ; =1 si je suis a l'IRCAM.
%DAC==0 ; =1 si ya les routines du DAC.
%PISYS==0 ; =1 ya les Interruptions Softs.
%STAT==0 ; =1 ya de l'auto-stat.
%TRPGC==0 ; =1 le GC est declenche sur TRAP : ill ref mem.
; si %TRPGC=1, yfo absolument que %PISYS=1 aussi...
; taille standard des zones de tavail.
N.ATOM=↑D500 ; NOMBRES D'ATOMES LITTERAUX.
N.NNUM=200 ; NOMBRE FIXES NEGATIFS.
N.PNUM=1000 ; NOMBRES FIXES POSITIFS.
N.NUMB=↑D1000 ; NOMBRES CREES.
N.STRG=↑D100 ; NOMBRE DE CHAINES.
N.LIST=↑D8000 ; NOMBRE DE DOUBLETS.
N.STAK=↑D1200 ; TAILLE PILE SYSTEME.
N.USTK=↑D500 ; TAILLE PILE UTILISATEUR ET DES TABLEAUX.
N.CODE=↑D200 ; TAILLE ZONE CODE.
; registres, constantes, OPDEF et externes FORTRANs.
RG=0 ; RENSEIGNEMENTS GENERAUX.
A1=1 ; GARBAGEABLES.
A2=2 ; ""
A3=3 ; ""
A4=4 ; ""
A5=5 ; NON GARBAGEABLES.
A6=6 ; ""
A7=7 ; ""
A8=10 ; ""
U1=11 ; USER 1
U2=12 ; USER 2
L=13 ; LIENS VERS S.P.
STRG=14 ; POINTEUR LISTE LIBRE DES CHAINES.
NUMB=15 ; POINTEUR LISTE LIBRE DES NOMBRES.
FREE=16 ; POINTEUR LISTE LIBRE DES DOUBLETS.
LAF=16 ; liste des arguments passes a FORTRAN.
P=17 ; POINTEUR DE PILE.
; constantes.
NIL=0
.XCREF A1,A2,A3,A4,A5,A6,A7,A8,P
.XCREF MEM,%%MTST
; OPDEF
OPDEF PPIOT [702B8]
OPDEF ARG [000B8]
OPDEF DDUPG [703B8]
; fonctions de la bibliotheque FORTRAN
EXTERNAL SQRT,EXP,ALOG,ALOG10,SIN,COS,ATAN,RAN
EXTERNAL EXP1.0,EXP3.0
IFN %DAC,<
EXTERNAL DACSET,DACCHN,DACFIL,DACRAT,DACREC,DACOUT
> ; de IFN %DAC
; bits du RG.
IBIT0==1 ; PRINT EVAL TIME.
IBIT1==2 ; PRINT TOP-LEVEL (DEF: OUI)
IBIT2==4 ; PRINT READ TOP-LEVEL (DEF: NON)
IBIT3==10 ; TRACE EVAL (DEF: NON)
IBIT4==20 ; TRACE APPLY (DEF: NON)
IBIT5==40 ; SPEAK G.C. (DEF: NON)
IBIT6==100 ; backtrace si erreur (def: oui)
IBIT7==200 ; check array (DEF: OUI)
IBIT8==400 ; step effectif (def: non)
IBIT9==1000 ; PRINT TRACE EFFECTIVE (DEF: OUI)
IBIT10==2000 ; IN IMPRIM TOUS LES ENREGS (DEF: NON)
IBIT11==4000 ; IN SUR TTY => ? READ (MIS PAR (INPUT))
IBIT12==10000 ; IN SIGNE PLUS + (DEF: NON).
IBIT13==20000 ; IN SIGNE MOINS - (DEF: OUI)
IBIT14==40000 ; IN QUOTEC (DEF: OUI)
IBIT15==100000 ; IN MACRO (DEF: OUI)
IBIT16==200000 ; IN MACRO-FN (DEF: OUI)
IBIT17==400000 ; IN STRINGS (DEF: OUI)
IBIT18==1B17 ; IN COMMENTS (DEF: OUI)
IBIT19==1B16 ; IN traduction minusc -> majusc (def: oui)
IBIT20==1B15 ; OUT IMPR EN FIN DE LIGNE (DEF: OUI)
IBIT21==1B14 ; OUT COMMENCE PAR ESPACE (DEF: OUI)
IBIT22==1B13 ; OUT SIGNE PLUS + (DEF: NON)
IBIT23==1B12 ; OUT SIGNE - (DEF: OUI)
IBIT24==1B11 ; OUT QUOTEC PNAME (DEF: NON)
IBIT25==1B10 ; OUT SPACE ENTRE ATOMES (DEF: OUI)
IBIT26==1B9 ; OUT MACROS-FN (DEF: OUI)
IBIT27==1B8 ; OUT CSTRING (DEF: OUI)
IBIT28==1B7 ;
IBIT29==1B6 ;
IBIT30==1B5 ; into IMPLODE.
IBIT31==1B4 ; into LIBRARY.
IBIT32==1B3 ; into READ.
IBIT33==1B2 ; ya eu une IT de type (Escape I)
IBIT34==1B1 ; cf : G.C. (bitgc)
IBIT35==1B0 ; into G.C.
RGSTD=1657761303 ; standard R.G.
BITGC=1B1 ; bit de marquage des doublets (G.C.)
BITRAC=10 ; bit de marquage des traces dans les F-types.
SUBTTL MACROS
LALL
MLON
PRINTX /1-MACROS./
;**********************************************************************
;
; C R E A T I O N D ' A T O M E S
;
;**********************************************************************
COMMENT \ tete d'un atome :
1 C-VAL P-liste
2 nb de caracteres car1 car2 car3 car4
du P-name.
3 car5 car6 car7 car8 car9
4 car10 car11 car12 car13 0 (toujours)
5 bits speciaux link (vers atome suivant)
6 indicateur special adresse speciale
(ex: SUBR FSUBR .. ) (ex: @ de lancement SUBR ...)
\
; creation d'un atome dont tous les composants sont donnes explicitement.
;?!? yaurait quand meme moyen de faire plus rapide ?
DEFINE MOBJ(ECVAL,ECPNA,ECIND,ECADR,ECNARG)<
.XCREF
XWD ECVAL,NIL
IFE %%MTST,<
XLIST>
EC==0
REPEAT 15,<EC==EC+1
GNUMB \EC,0>
EC==0
IRPC ECPNA,<EC==EC+1
GNUMB \EC,"ECPNA">
BYTE (7)EC,P1,P2,P3,P4
BYTE (7)P5,P6,P7,P10,P11
BYTE (7)P12,P13,P14,P15,0
; pourquoi mon dieu n'y-a-t-il pas de si alors sinon ...
IFIDN <ECIND><FSUBR>,<
XWD 6,.-MEMAD-12>
IFDIF <ECIND><FSUBR>,<
IFIDN <ECIND><SUBR>,<
IFB <ECNARG>,<
XWD 5,.-MEMAD-12>
IFNB <ECNARG>,<
XWD ECNARG+1,.-MEMAD-12>>
IFDIF <ECIND><SUBR>,<
XWD 0,.-MEMAD-12>>
.CREF
XWD ECIND,ECADR
LIST>
; car \ n'est utilisable qu'en argument de macro !?!
DEFINE GNUMB(XX,YY)<
P'XX==YY>
; creation d'un atome de fonction
DEFINE MOBJT(PN,IND,ADR,NARG)<
MOBJ UNDEF,PN,IND,ADR,NARG>
; creation d'atomes de meme type et de meme nb d'args.
; ATTENTION : le PNAME doit etre l'adresse de lancement.
DEFINE MATOM(PN,IND,NARG)<
IRP PN,<
MOBJ UNDEF,PN,IND,PN,NARG>>
; definition d'atomes AUTOLOAD.
DEFINE MAUTO(PN,FILE)<
IRP PN,<
MOBJ UNDEF,PN,A.AUTO,FILE>>
IFN %%MTST,<
LALL
MOBJ (NIL,LINELENGTH,SUBR,PLENGTH,1)
MATOM <CAR,CDR>,SUBR,1
SALL
>
; macros : SKIP & JUMP.
; T E S T (SKIP OU JUMP) SUR LES DIFFERENTS TYPES.
;
; TYPE = NIL : VALEUR NIL.
; = ATOM : ATOME LITTERAL.
; = NUMB : NOMBRE.
; = STRG : CHAINE.
; = LIST : LISTE.
;
; MACROS :
; SK'TYPE' R SKIP SI R EST DU TYPE 'TYPE'.
; SN'TYPE' R SKIP SI R N'EST PAS DU TYPE 'TYPE'.
; JP'TYPE' R,LAB JUMP EN LAB SI LE TYPE DE R EST 'TYPE'.
; JN'TYPE' R,LAB JUMP EN LAB SI LE TYPE DE R N'EST PAS 'TYPE'.
; MACRO INTERNE : GENERE UN POPJ OU UN JRST
DEFINE %%RET(L)<
IFIDN <L><VPOPJ>,<
POPJ P,>
IFDIF <L><VPOPJ>,<
JRST L>
LIST>
; TYPE = NIL
DEFINE SKNIL(R)<
SKIPE R>
DEFINE SNNIL(R)<
SKIPN R>
DEFINE JPNIL(R,LAB)<
JUMPE R,LAB>
DEFINE JNNIL(R,LAB)<
JUMPN R,LAB>
; TYPE = ATOM (ATOME LITTERAL)
DEFINE SKATOM(R)<
CAML R,BNUMB>
DEFINE SNATOM(R)<
CAMGE R,BNUMB>
DEFINE JPATOM(R,LAB)<
CAMGE R,BNUMB
IFE %%MTST,<
XLIST>
%%RET LAB>
DEFINE JNATOM(R,LAB)<
CAML R,BNUMB
IFE %%MTST,<
XLIST>
%%RET LAB>
; TYPE = NUMB (NOMBRE)
DEFINE SKNUMB(R)<
CAML R,BNUMB
IFE %%MTST,<
XLIST>
CAML R,BSTRG
LIST>
DEFINE JNNUMB(R,LAB)<
CAML R,BNUMB
IFE %%MTST,<
XLIST>
CAML R,BSTRG
%%RET LAB>
; TYPE = STRG (CHAINE).
DEFINE SKSTRG(R)<
CAML R,BSTRG
IFE %%MTST,<
XLIST>
CAML R,BLIST
LIST>
DEFINE JNSTRG(R,LAB)<
CAML R,BSTRG
IFE %%MTST,<
XLIST>
CAML R,BLIST
%%RET LAB>
; TYPE = LIST (LISTE)
DEFINE SKLIST(R)<
CAMGE R,BLIST>
DEFINE SNLIST(R)<
CAML R,BLIST>
DEFINE JPLIST(R,LAB)<
CAML R,BLIST
IFE %%MTST,<
XLIST>
%%RET LAB>
DEFINE JNLIST(R,LAB)<
CAMGE R,BLIST
IFE %%MTST,<
XLIST>
%%RET LAB>
IFN %%MTST,<
LALL
SKNIL A1
SNNIL A1
JPNIL A1,START
JNNIL A1,START
SKATOM A1
SNATOM A1
JPATOM A1,START
JPATOM A1,VPOPJ
JNATOM A1,START
SKNUMB A1
JNNUMB A1,START
SKSTRG A1
JNSTRG A1,START
SKLIST A1
SNLIST A1
JPLIST A1,START
JNLIST A1,START
JNLIST A1,VPOPJ
SALL
>
; macros : CONSL
; CONSL RD,CAR,CDR CRE LE DOUBLET (CAR.CDR)
; ADRESSE RESULTANTE DANS RD.
;
; CONSL RD, - , - RIEN
; RD, - ,NIL HLRI RD,0
; RD, - ,CDR HRR RD,CDR
; CONSL RD,NIL, - HLLI RD,0
; RD,NIL,NIL SETZ RD,0
; RD,NIL,CDR HRRZ RD,CDR
; CONSL RD,CAR, - HRL RD,CAR
; RD,CAR,NIL HRLZ RD,CAR
; RD,CAR,CDR HRL RD,CAR
; HRR RD,CDR
DEFINE CONSL(RD,CAR,CDR)<
IFB <CAR>,<
IFNB <CDR>,<
IFE CDR,< HLRI RD,0>
IFN CDR,< HRR RD,CDR>>>
IFNB <CAR>,<
IFE CAR,<
IFB <CDR>,< HLLI RD,0>
IFNB <CDR>,<
IFE CDR,< SETZ RD,0>
IFN CDR,< HRRZ RD,CDR>>>
IFN CAR,<
IFB <CDR>,< HRL RD,CAR>
IFNB <CDR>,<
IFE CDR,< HRLZ RD,CAR>
IFN CDR,< HRL RD,CAR
HRR RD,CDR>>>>
IFE %%MTST,<
XLIST
>
IFE %TRPGC,<
JUMPN FREE,.+2
PUSHJ P,GARBCL
>
EXCH RD,MEM(FREE)
EXCH FREE,RD
LIST>
IFN %%MTST,<
LALL
CONSL A1,,
CONSL A1,,NIL
CONSL A1,,A2
CONSL A1,NIL,
CONSL A1,NIL,NIL
CONSL A1,NIL,A2
CONSL A1,A2,
CONSL A1,A2,NIL
CONSL A1,A2,A3
SALL
>
; macros : GETCAR GETCDR PUTCAR PUTCDR UNCONS et freres.
; MACROS DE MANIPULATION DE LISTE
;***** GETCAR (RS,RD) : RD:=(CAR RS)
DEFINE GETCAR(RS,RD)<
HLRZ RD,MEM(RS)>
;***** GETCDR (RS,RD) : RD:=(CDR RS)
DEFINE GETCDR(RS,RD)<
HRRZ RD,MEM(RS)>
;***** PUTCAR (RD,RS) : (CAR RD):=RS
DEFINE PUTCAR(RD,RS)<
HRLM RS,MEM(RD)>
;***** PUTCDR (RD,RS) : (CDR RD):=RS
DEFINE PUTCDR(RD,RS)<
HRRM RS,MEM(RD)>
;***** UNCONS (RS,CAR,CDR) : CAR:=(CAR RS) & CDR:=(CDR RS)
DEFINE UNCONS(RS,CAR,CDR)<
IFE RS-CAR,< HRRZ CDR,MEM(RS)
IFE %%MTST,<
XLIST>
HLRZ CAR,MEM(RS)>
IFN RS-CAR,< HLRZ CAR,MEM(RS)
IFE %%MTST,<
XLIST>
HRRZ CDR,MEM(RS)>
LIST>
;***** ADLIST (RD,RS) : (CDR RD):=RS & RD:=(CDR RD)
DEFINE ADLIST(RD,RS)<
HRRM RS,MEM(RD)
IFE %%MTST,<
XLIST>
HRRZ RD,MEM(RD)
LIST>
IFN %%MTST,<
LALL
GETCAR A1,A2
GETCDR A1,A2
PUTCAR A1,A2
PUTCDR A1,A2
UNCONS A1,A2,A3
UNCONS A1,A1,A2
UNCONS A1,A2,A1
ADLIST A1,A2
SALL
>
; macros : SETBIT CLRBIT JPBIT JNBIT et freres.
; MACROS DE MANIPULATION ET DE TEST DES BITS DU R.G. (REG 0)
;
; POUR TOUTES CES MACROS, N REPRESENTE 1 OU PLUSIEURS BITS;
; L'ACCES IMMEDIAT A GAUCHE, IMMEDIAT A DROITE OU DIRECT , EST
; CALCULE AUTOMATIQUEMENT (PAR LES MACROS DE C.MAC).
;***** SETBIT N : POSITIONNE LE (OU LES) BIT(S) N DU RG.
DEFINE SETBIT(N)<
TXO RG,N>
;***** CLRBIT N : ENLEVE LE (OU LES) BIT(S) N DU RG.
DEFINE CLRBIT(N)<
TXZ RG,N>
;***** SKBIT N : SKIP SI LE (OU LES) BIT(S) DU RG EST PRESENT.
DEFINE SKBIT(N)<
TXNN RG,N>
;***** SNBIT N : SKIP SI LE (OU LES) BIT(S) DU RG ESP ABSENT.
DEFINE SNBIT(N)<
TXNE RG,N>
;***** JPBIT N,LAB : JUMP SI LE (OU LES) BIT(S) DU RG EST PRESENT.
DEFINE JPBIT(N,LAB)<
TXNE RG,N
IFE %%MTST,<
XLIST>
%%RET LAB
LIST>
;***** JNBIT N,LAB : JUMP SI LE (OU LES) BIT(S) DU RG EST ABSENT.
DEFINE JNBIT(N,LAB)<
TXNN RG,N
IFE %%MTST,<
XLIST>
%%RET LAB
LIST>
IFN %%MTST,<
LALL
BIT1==1B1
BIT20==1B20
SETBIT BIT1
SETBIT BIT20
SETBIT BIT1!BIT20
JNBIT BIT20,START
JPBIT BIT1,VPOPJ
SALL
>
; macros : SAVR BABYL MOVEMM MEXP
; A U T R E S M A C R O S
; Sauvetage multiple de registres.
DEFINE SAVR(P1,P2,P3)<
PUSH P,P1
IFE %%MTST,<
XLIST>
IFNB <P2>,<
PUSH P,P2>
IFNB <P3>,<
PUSH P,P3>
LIST>
; restauration multiple de regitres (cf SAVR)
DEFINE BABYL(P1,P2,P3)<
POP P,P1
IFE %%MTST,<
XLIST>
IFNB <P2>,<
POP P,P2>
IFNB <P3>,<
POP P,P3>
LIST>
; MOVEMM ADR,REG,ADR
DEFINE MOVEMM(P1,P2,P3)<
MOVE P2,P1
IFE %%MTST,<
XLIST>
MOVEM P2,P3
LIST>
; Multiple EXP
DEFINE MEXP(P1,P2,P3,P4,P5,P6,P7,P8)<
EXP P1
IFE %%MTST,<
XLIST>
IFNB <P2>,<
EXP P2>
IFNB <P3>,<
EXP P3>
IFNB <P4>,<
EXP P4>
IFNB <P5>,<
EXP P5>
IFNB <P6>,<
EXP P6>
IFNB <P7>,<
EXP P7>
IFNB <P8>,<
EXP P8>
LIST>
;;;;; FIN DES MACROS ;;;;;
SALL
%%MTST==0
SUBTTL IMPUR STORAGE
PRINTX /2-MEM.INIT/
;********************************************************************
; I M P U R E S T O R A G E
;********************************************************************
; MEMOIRES NON DUMPABLES .................
CBLK: BLOCK 3 ; BLOCK DE CONTREOLE DE CORE.
; MEMOIRES SYSTEME
CCL: Z ; =0 SI NON CCL ENTRY.
ONCEFG: EXP -2 ; -2 si interprete froid.
; i.e. nb de start autorises.
INICOR: Z ; .JBFF + .JBREL INITIAL.
SVCORA: Z ; .JBFF + .JBREL SI I/O/D/L
SVCORT: Z ; NO CHANNEL DU SVCORA.
MYPPN: Z ; PPN UTILISATEUR.
PNJOB: Z ; NO DU JOB DE L'UTILISATUEUR.
; MEMOIRES DUMPABLES .......................
BIMPUR=.
; MEMOIRES TEMPORAIRES POUR LES SUBRS.
TEMP$P: Z ; SAUVEGAARDE DE P.
TEMP$F: Z ; SAUVEGARDE D'UNE FONCTION.
TEMP$L: Z ; SAUVEGARDE DE 'LAST'.
TEMP$T: Z ; SAUVEGARDE D'UN TEST (INTERDIT SI CONS)
TEMP$0: Z ; [PAT] AUG 17 1978. USED BY SUBST
TEMP$1: Z ; [PAT] AUG 17 1978. USED BY SUBST
; core : impur storage (configurateur) .
SIZAT=6 ; taille d'1 atome.
SIZATT=SIZAT*N.ATOM ; taille de la zone atome.
SIZNB=2 ; taille d'1 nombre.
SIZNBT=SIZNB*N.NUMB+N.NNUM+N.PNUM ; taille de la zone nombre.
MEMAX=SIZATT+SIZNBT+N.STRG+N.LIST ; taille de MEM totale.
; ces memoires sont sont chargees par le fonction CONFIGURATION
; ou bien alors initilialisees par le systeme.
; Ce sont elles qui servent pour initilaliser les zones.
C.ATOM: EXP N.ATOM ; nb d'atomes utilisateurs.
C.NNUM: EXP N.NNUM ; nb de nb fixes negatifs.
C.PNUM: EXP N.PNUM ; nb de nb fixes positifs.
C.NUMB: EXP N.NUMB ; nb de nb cres.
C.STRG: EXP N.STRG ; nb de chaines.
C.LIST: EXP N.LIST ; nb de doublets de liste libre.
C.STAK: EXP N.STAK ; taille de la pile systeme.
C.USTK: EXP N.USTK ; taille des tableaux (+ pile user).
C.CODE: EXP N.CODE ; taille de la zone code.
C.MEND: EXP MEMAX
; memoires pointant sur MEM.
Z
CATOM:: EXP 0 ; courant atomes.
SATOM:: EXP MEMAF-MEMAD ; fin zone atome systeme.
FATOM: EXP 0 ; point liste libre des atomes.
BNUMB:: EXP 0 ; debut des nombres.
PZER:: EXP 0 ; pointeur sur zero 0.
BCNUM:: EXP 0 ; debut des nbs cres.
BSTRG:: EXP 0 ; debut zone chaines.
BLIST:: EXP 0 ; debut listes.
ELIST:: EXP 0 ; fin de MEM.
BPILE:: EXP 0 ; debut de la pile syst.
PILINI: EXP 0 ; init du pointeur de pile.
USTCKB::EXP 0 ; debut pile utilisateur.
USTCKC::EXP 0 ; courant pile utilisateur.
USTCKE::EXP 0 ; fin pile user & debut des tableaux.
USTCKF::EXP 0 ; fin de cette zone.
BCODEB::EXP 0 ; debut zone code.
BCODEC::EXP 0 ; courant zone code.
BCODEE::EXP 0 ; fin zone code.
MEMEND::EXP 0 ; fin du low-seg.
; CORE : impur storage (constantes d'init)
INSTRT: EXP 0 ; contient le fichier d'init
; CONFIG.INI ou VLISP.INI
; fichiers standards configures.
FL.INI:
SIXBIT /DSK/
SIXBIT /CONFIG/ ; fichier d'entree initial.
SIXBIT /INI/
FL.INP:
SIXBIT /TTY/ ; fichier d'entree standard.
SIXBIT /LISPIN/
SIXBIT /VLI/
FL.OUT:
SIXBIT /TTY/ ; fichier de sortie standard.
SIXBIT /LISPOU/
SIXBIT /LST/
; CORE : impur storage (pile) .
; PILE
;
; POUR L'UTILISATION DE LA PILE
;
P$BIND::Z ; CHAINAGE DES BINDS (init [-1,,-1].
P$NAME: Z ; NOM DES BLOCKS.
P$LABEL:Z ; CHAINAGE DES TABLES D'ETIQUETTES (PROG DO)
P$DO: Z ; CHAINAGE DES DO.
P$BREAK:Z ; CHAINAGE DES BREAKS.
; mots speciaux de marquage de la pile.
; Ils ont tous negatifs (a cose du G.C.)
MRK.MRK: EXP -1 ; marque temporaire de la pile.
; ainsi que la valeur du 1er P$BIND.
MRK.LAM: XWD -1,0 ; marque lambda-frame.
MRK.ESC: XWD -2,0 ; marque escape-frame.
MRK.PRG: XWD -3,0 ; marque prog-frame.
MRK.DO: XWD -4,0 ; marque do-frame.
MRK.BRK: XWD -5,0 ; marque break-frame.
; La fin des couples [var,,val] est signalee par le
; stack pointer of old P$BIND qui lui est tjrs negatif.
COMMENT \ ************************
ORGANISATION DE LA PILE.
************************
[ (lambda .. ...) ] derniere lambda ou dernier nom
de la fonction compilee.
(pour SELF et les tails-recs).
P$BIND --> [ -1 ,, point. to end frame] LAMBDA/GAMMA frame
[ VAR N ,, VAL N ]
[ VAR N-1 ,, VAL N-1 ]
......
[ VAR 1 ,, VAL 1 ]
[ stack point. of old P$BIND ]
P$BIND --> [ -2 ,, point. to end frame] ESCAPE frame
[ VAR ESC ,, VAL ESC ]
[ stack point. of old P$BIND ]
[ NOM DU ESCAPE ]
P$LABEL --> [ LAB N ,, VAL N ] PROG frame
[ LAB N-1 ,, VAL N-1 ]
......
[ LAB 1 ,, VAL 1 ]
[ -1 ]
P$BIND --> [ -3 ,, point. to end frame]
[ VAR N ,, VAL N ]
[ VAR N-1 ,, VAL N-1 ]
......
[ VAR 1 ,, VAL 1 ]
[ stack point. of old P$BIND ]
[ PROG ]
[ OLD P$LABEL ]
P$LABEL --> [ LAB N ,, VAL N ] DO frame
[ LAB N-1 ,, VAL N-1 ]
......
[ LAB 1 ,, VAL 1 ]
[ -1 ]
P$DO --> [ ((TEST REP) BODY) ]
[ (LIST REP) ]
[ (LIST VAR) ]
P$BIND --> [ -4 ,, point. to end frame]
[ VAR N ,, VAL N ]
[ VAR N-1 ,, VAL N-1 ]
[ ...... ]
[ VAR 1 ,, VAL 1 ]
[ -1 ]
[ stack point. of old P$BIND ]
[ DO ]
[ OLD P$LABEL ]
[ OLD P$DO ]
\
; CORE : memoire pour le G.C.
GC.BEG==.
GARBN: Z ; GARBAGE NUMBER.
GARBC: Z ; GARBAGE COUNT.
GARBM: Z ; MARKED CELLS.
GARBA: Z ; ALTERED CELLS.
GARBF: Z ; FREE CELLS.
GARBP: Z ; SAVE STACK POINTER.
GARBT: Z ; G.C. TIME.
GC.NGN: Z ; nb de GC dus aux nombres.
GC.NGS: Z ; nb de GC dus aux chaines.
GC.NGA: Z ; nb de GC dus aux atomes.
GC.NGL: Z ; nb e GC dus aux listes.
GC.NGY: Z ; nb de GC dus au systeme.
GC.MST: Z ; NB DE CHAINES MARQUEES.
GC.FST: Z ; NB DE CHAINES LIBEREES.
GC.MNB: Z ; NB DE NOMBRES MARQUES.
GC.FNB: Z ; NB DE NOMBRES LIBERES.
GC.MAT: Z ; nb d'atomes marques.
GC.FAT: Z ; nb d'atomes liberes.
GC.TTT: Z ; temps total utilise par le G.C.
GC.TTI: Z ; temps total utiise par VLISP.
GARBL: DEC 200 ; G.C. LIMIT.
GARBSV: BLOCK 12 ; SAVE AERA REGISTERS.
GC.END==.
; CORE : impur storage (interrupt) .
IFN %PISYS,<
VECTOR: ; vecteur d'interruptions.
;;; dans le 1er ya rien [1].
BLOCK 4
;;; pdl overflow [2].
EXP ERPDL ; new PC.
MEXP Z,Z,Z ; old PC. flags,,reasons. status word.
;;; ESCAPE-I [3].
EXP TESCI ; new PC.
MEXP Z,Z,Z ; old PC. flags,,reasons. status word.
;;; Arith. exceptions [4].
EXP EROVFL ; new PC.
MEXP Z,Z,Z ; old PC. flags,,reasons. status word.
;;; Ill ref. memory [5].
EXP ERILRM ; new PC.
MEXP Z,Z,Z ; old PC. flags,,reasons. status word.
PDLBLK: ;;; block de controle pour l'IT 2 (pld ovl).
EXP .PCPDL ; (-11)8.
XWD 4,0 ; offset in VECTOR,, pas d'i/o.
Z ; priority,,reserved.
BESCPI: ;;; block de controle pour l'IT 3 (escape i)
EXP .PCABT ; (-2)8
XWD ↑D8,0 ; offset ,, pas d'i/o.
Z ; reserve.
ARIBLK: ;;; block de controle pour l'IT 4 (arith except.)
EXP .PCARI ; (-10)8.
XWD ↑D12,0 ; offset ,, pas d'i/o.
Z ; reserve.
IRMBLK: ;;; block de controle pour l'IT 5 (ill ref. mem.)
EXP .PCIMR ; (-6)8.
XWD ↑D16,0 ; offset,,pas d'i/o.
Z ; reserve.
NESCPI: Z ; nombre argument du ESC-I.
> ; FIN DU %PISYS.
; pour le ↑C interception.
INTBLK:
XWD 4,INTLOC ; start interrupt.
XWD 0,2 ; ↑C.
Z ; last PC.
Z ; LH intercept type.
Z ; save AC.
; CORE : pour le display DM IRCAM.
UPGBLK: 460000,,UPGBUF
Z ; length msg
Z ; flags
Z ; ?!? voir dart.
UPGBFM=↑D20 ; taille max buffer.
UPGBUF: BLOCK UPGBFM ; buffer DM.
DMBUF: BYTE (7)177,14,140,142 ; col 0 line 3.
Z ; pour le G.C. NO.
BYTE (7)"#"," "," " ; separateur.
Z ; pour le pourcentage.
BYTE (7)"%"," "," " ; separateur.
Z ; pour le nombre
Z ; de doublets libres.
BYTE (7)"l"," "," " ; separateur.
Z ; pour le nb d'atomes liberes.
BYTE (7)"a","t"," "," "," " ; dernier separateur.
UPGIOB: 460000,,DMBUF ; overlap + truncat + noeeol
EXP ↑D10 ; long du message.
Z ; flag
Z ; (ya 1 mot en plus sur DART ?!?)
; CORE : pour le display DATADISC SAIL.
DDBLK: 200000,,DDPROG
Z ; length dd-prog
Z
DDPROG+1 ; adress of col-line-select.
DDPROG: BYTE (8)66,0,66(3)1,2,1,4 ; txt,chn0,txt,fn,chan,fn,cw.
Z ; contiendra DDLICO actualise.
DDBFM=↑D20 ; taille max buffer.
DDBUF: BLOCK DDBFM ; le buffer de caracteres a balancer.
DDLICO: BYTE (8) 0,0, 0(3)3,4,5,4 ; ncol,nhilin,nlolin,col,hilin,
; lolin,cw.
; CORE : fonctions standards (TOPLEVEL INPUT OUTPUT DIRECTORY)
; TOPLEVEL
EVTIME: Z ; TEMPS D'UNE EVALUATION AU TOP-LEVEL.
; CONVERSIONS.
CVSATM: Z ; SAUVEGARDE SIXBIT -> ATOME.
; INPUT
INB: XWD 0,1 ; ASCII LINE
SIXBIT /TTY/ ; DEVICE
XWD 0,IBLK
IBLK: BLOCK 3
INF: SIXBIT /VLISP/ ; FILENAME
SIXBIT /VLI/ ; EXTENSION HD2 D1
Z ; PROT M T LD2
Z ; PJ.PG
; OUTPUT
OUTB: XWD 0,0 ; ASCII
SIXBIT /TTY/ ; DEVICE
XWD OBLK,0
OBLK: BLOCK 3
OUTF: SIXBIT /VLISP/
SIXBIT /LST/ ; EXTENSION.
Z ; PROT M T LD2
Z ; PJ.PG
; DIRECTORY
DIRB: XWD 0,10 ; 36 BITS.
SIXBIT /DSK/ ; DEVICE
XWD 0,DBLK
DBLK: BLOCK 3
DIRF: Z ; DIRECTORY NAME.
SIXBIT /UFD/
Z
MFDPPN: Z
DIRFIL: Z ; FILNAME A TESTER.
DIREXT: Z ; EXTENSION A TESTER.
; CORE : fonctions standards (FILOP TMPCOR)
; FILOP
FILOPB: Z ; channel ,, function
Z ; IOmode ou # USETI/O
Z ; device name ou #UDX.
XWD OBLK,IBLK ;
XWD NOUBUF,NINBUF
XWD FILOPR,FILOPF
; ENTER/LOOKUP block pour FILOP
FILOPF: Z ; filename
Z ; ext ,, hd2 d1
Z ; prot m t ld2
Z ; pj ,, pg
; RENAME Block pour FILOP
FILOPR: Z ; filename
Z ; ext ,, hd2 d1
Z ; prot m t ld2
Z ; pj ,, pg
; TMPCOR
TMPCRM==↑D19 ; taille du buffer du TMPCOR.
TMPCRB: BLOCK TMPCRM ; buffer de lecture du TMPCOR.
Z ; qui doit se terminer par 0.
TMPCRA: XWD 0,0 ; name,,0
IOWD TMPCRM,TMPCRB ; taille et adr buffer.
TMPCRP: Z ; cntient le point de chaine sur TMPCRB.
; CORE : fonctions standard (LIBRARY CORE RUN GETSPC ...)
; LIBRARY
LIBB: XWD 0,0 ; ASCII
SIXBIT /DSK/ ; DEVICE
XWD 0,LBLK
LBLK: BLOCK 3
LIBF: Z ; FILENAME
SIXBIT /VLI/ ; EXTENSION
Z
Z ; USER PPN OR SYS.
LIB$P: Z ; SAVE P IN LIBRARY.
LIB$PM==10 ; MAX TABLE DE PATHLIBRARY.
LIB$PA: MEXP 0,0,-1 ; USER SYS: END.
BLOCK LIB$PM-3
; CORE
CORB: XWD 0,10 ; 36 BITS,
SIXBIT /DSK/
XWD CBLK,CBLK
; LE CBLK N'EST PAS EN ZONE DUMPABLE.
CORF: SIXBIT /TEMPOR/ ; FILENAME.
SIXBIT /COR/ ; EXT
Z
Z ; PJ.PG
; RUN
RUNBLK: SIXBIT /SYS/ ; device
Z ; filename
Z ; ext low seg
Z ; =0 toujours
Z ; PPN
Z ; adress max du low seg
; GETSPC
GTF$DV: Z ; DEVICE
GTF$FL: Z ; FILENAME.
GTF$EX: Z ; EXTENSION.
GTF$PR: Z ; protection
; SETACTABLE
SETCTO: BLOCK 4
SETCTN: BLOCK 4
TRMOPB: BLOCK 3
; CORE : fonctions d'entree sortie.
; FONCTIONS D'ENTREE
INCHAR: Z ; @ DE LA ROUTINE QUI LIVRE LE CAR SUIV.
GETNXP: Z ; POINTEUR GETNEX.
GETNXC: Z ; COMPTEUR GETNEX.
PINTER: BYTE (7)"?"," "," "
PSPACE: BYTE (7)" "," "," "
CONSER: Z ; GARDE LE CARACTERE AU FRAIS (GETCH)
COMMEN: EXP ";" ; DELIMITEUR DE CPMMENTAIRES.
QUOTEC: EXP "/" ; QUOTE CARACTERE.
CSTRIN: OCT 42 ; DELIMITEUR DE CHAINE " .
DPREAD: Z ; Profondeur courante d'entree
; (i.e. le nb de "(" ou "[" )
; TABLE DES CARACTERES.
; 0 = BREAK
; 1 = NULL
; 2 = NORMAL
; 3 = .
; 4 = (
; 5 = )
; 6 = [
; 7 = ]
TABCAR:
MEXP 0,0,0,0,0,0,0,2 ; 000 CONTROLS ... BELL
MEXP 0,1,0,0,0,0,1,0 ; 010 BS TAB LF VT FF CR /N /O
MEXP 0,0,0,0,0,0,0,0 ; 020 /P XON /R XOFF /T /U /V /W
MEXP 0,0,0,0,0,0,0,0 ; 030 /X /Y EPF ESC SEPARATORS ...
MEXP 1,2,2,2,2,2,2 ; 040 ESP ! " # $ % &
XWD MQUOTE,2 ; 047 ' (QUOTE)
MEXP 4,5,2,2,2,2,3,2 ; 050 ( ) * + , - . /
MEXP 2,2,2,2,2,2,2,2 ; 060 0 1 2 3 4 5 6 7
MEXP 2,2,2,2,2,2,2,2 ; 070 8 9 : ; < = > ?
MEXP 2,2,2,2,2,2,2,2 ; 100 @ A B C D E F G
MEXP 2,2,2,2,2,2,2,2 ; 110 H I J K L M N O
MEXP 2,2,2,2,2,2,2,2 ; 120 P Q R S T U V W
MEXP 2,2,2,6 ; 130 X Y Z [
XWD MOCTAL,2 ; 134 \
MEXP 7,2,2 ; ] ! ←
MEXP 2,2,2,2,2,2,2,2 ; 140 MINUSCULES
MEXP 2,2,2,2,2,2,2,2 ; 150 MINUSCULES
MEXP 2,2,2,2,2,2,2,2 ; 160 MINUSCULES
MEXP 2,2,2,2,2,2,2,0 ; 170 MINUSCULES RUBOUT.
TABCAF==.-1 ; FIN TABCAR POUR G.C.
; READ
SIGNE: Z ; SIGNE D'UN NB. (0 -1)
IBASE: DEC 10 ; BASE DES NOMBRES EN ENTREE.
IBASEX: IMUL A5,IBASE ; instruction a executer par un XCT pour les
; conversions d'entree.
MAXCP==↑D13 ; nb de caracteres dans le PNAME des atomes.
MAXCPP==↑D39 ; chien de garde du buffer Pname.
PNAM0: Z ; pour le BLT de la zone P-name.
PNAME: BLOCK 8 ; buffer PNAME (jusqu'a 36 caracteres).
LASTRD: Z ; LAST READ POUR STATUS 20.
; IMPLODE
IMPLOL: Z ; liste des caracteres a interner.
IMPLOC: Z ; dernier CONSER a preserver.
; FONCTIONS DE SORTIE
PRPREF: OCT 40 ; PREFIXE IMPRESSION.
BUFOUB: OCT 40 ; SPACE POUR RAZ.
BUFOUT: BLOCK 200 ; BUFFER DE SORTIE.
BUFOUP: Z ; POINTEUR SUR CE BUFFER.
BUFOUL: DEC 68 ; LONGEUR MAXI DE LA LIGNE.
PRTYPE: Z ; TYPE PRECEDENT = 0 SI ")".
PRMARG: Z ; MARGE GAUCHE BUFOUT.
PRSTRG: BLOCK 20 ; BUFFER STRING.
PSTR: Z ; POINTEUR BUFFER STRING.
OBASE: DEC 10 ; BASE DE SORTIE.
PREFOR: EXP "?" ; PREFIXE FORM.
PREFTO: EXP "=" ; PREFIXE TOP-LEVEL.
PREFPR: EXP " " ; PREFIXE PRINT.
PRDPM: EXP ↑D50 ; profondeur max du print.
PRDPC: Z ; profondeur courante du PRINT.
PRLNM: EXP ↑D2000 ; long d'elements max du PRINT.
PRLNC: Z ; long courante du PRINT.
; EVAL
LFORME: Z ; Last Forme in Eval.
; EXPLODE
EXPLOP: Z ; POINTEUR PNAME ATOME.
; GENSYM
GENSYP: Z ; POINTEUR STRING PNAME.
GENSYC: DEC 100 ; COMPTEUR GENSYM.
GENSYN: Z ; NB DE CARACTERES.
; PLENGTH
PLGC: Z ; COUNTER DE PLENGTH.
PLGT: Z ; TEST DE PLENGTH.
; CORE : FORTRAN et DAC.
XWD 0,0 ; -nb d'argument. (RANDOM)
APFRL0:
ARG 0,0 ; type=non defini.
XWD -1,0 ; -nb d'argument. (SQRT)
APFRL1:
ARG 4,0 ; type=real, value chargee apres.
; car ARG 4,mem(A1) ne marche pas :
; je sais pas squiya dans FORLIB.
IFN %DAC,<
BDAC: BLOCK ↑D4000 ; buffer DAC.
DACR: Z ; resultat de l'echange.
XWD -3,0 ; -nb d'arguments.
APFRL3:
ARG 4,0 ; 1er arg flottant : taille du buffer.
ARG 4,BDAC ; 2eme arg adresse du buffer
ARG 4,DACR ; adresse du compte rendu.
> ; IFN %DAC
SUBTTL MEM OBJET
; zone M E M == objets LISP
; on y accede par indexation/MEM : MEM(objet LISP).
; ya : atomes - nombres - chaines - listes.
;?!? ----- il faudrait changer les indicateurs .FSUBR .2SUBR ...
MEM::
MEMAD=.
;*** constantes.
; NIL
XWD NIL,NIL
BYTE (7)3,"N","I","L" ; P-name 1
XWD 0,0 ; P-name 2
XWD 0,0 ; P-name 3
XWD 0,-1 ; bits spec ,, Link
XWD 0,0 ; indic spec ,, @ speciale.
T=.-MEMAD
MOBJ T,T
UNDEF=.-MEMAD
MOBJ UNDEF,UNDEF
QUOTE=.-MEMAD
MOBJ QUOTE,QUOTE,FSUBR,CAR
ACOMFN=.-MEMAD
MOBJ ACOMFN,COMMENT,FSUBR,ACMMFN
LAMBDA=.-MEMAD
MOBJ LAMBDA,LAMBDA,FSUBR,ALAMDA
GAMMA=.-MEMAD
MOBJ GAMMA,GAMMA
EXPR=.-MEMAD
MOBJ EXPR,EXPR
FEXPR=.-MEMAD
MOBJ FEXPR,FEXPR
MACRO=.-MEMAD
MOBJ MACRO,MACRO
ARRAY=.-MEMAD
MOBJ ARRAY,ARRAY
SUBR=.-MEMAD
MOBJ SUBR,SUBR,SUBR,ASUBR,2
FSUBR=.-MEMAD
MOBJ FSUBR,FSUBR,SUBR,AFSUB,2
MACIN=.-MEMAD
MOBJ MACIN,MACIN
MACOUT=.-MEMAD
MOBJ MACOUT,MACOUT
AESC=.-MEMAD
MOBJ UNDEF,:::::ESC
; MEM OBJ : I/O.
A.IT=.-MEMAD
MOBJ NIL,IT
A.TOPLV=.-MEMAD
MOBJT TOPLEVEL,SUBR,TOPLEV
MATOM <TYI,TYS>,SUBR,0
MATOM <TYO>,SUBR,1
MOBJT SETACTABLE,SUBR,ASETAC,1
MOBJT PPIOT,SUBR,APPIOT,2
MOBJT CALLI,SUBR,ACALLI,2
MOBJT UPGIOT,SUBR,UPGIO,2
MATOM <DISPLAY>,SUBR,2
MATOM <TRMOP>,SUBR,3
MATOM <XYDISPLAY>,SUBR,3
;*** L04 *** I/O/D/L
MATOM <ALIAS>,SUBR,1
; MATOM <SHOWIT>,SUBR,1
MATOM <TMPCOR>,SUBR,1
MATOM <FILOP>,SUBR,3
MATOM <INPUT,OUTPUT,WRCORE,RDCORE>,SUBR,1
MATOM <DIRECTORY>,SUBR,2
MOBJT RUN,SUBR,ARUN,2
MATOM <LIBRARY,PATHLIBRARY>,FSUBR
;*** L05 *** INPUT
A.EOF=.-MEMAD
MATOM <EOF,TEREAD,READCH,PEEKCH>,SUBR,0
MOBJT READ,SUBR,READU,0
MATOM <IMPLODE>,SUBR,1
;*** L06 *** output.
MOBJT OUTBUF,SUBR,FOUTBF,2
MOBJT PRIN1,SUBR,PRIN1U
MOBJT PRINT,SUBR,PRINTU
MATOM <TERPRI,TTAB,SPACES>,SUBR,1
MATOM <PRINC>,SUBR,2
MOBJT PAGE,SUBR,APAGE,0
MOBJT PRINTLEVEL,SUBR,PRLVL,1
MOBJT PRINTLENGTH,SUBR,PRLNG,1
A.ET=.-MEMAD
MOBJT &
; MEM OBJ : interprete controle et fonctionnelles.
MATOM <SELF,APPLYN>,SUBR
A.EVAL=.-MEMAD
MATOM <EVAL,EVLIS,EPROGN>,SUBR,1
MOBJT APPLY,SUBR,APPLYU,2
MOBJT PROGN,FSUBR,EPROGN
MATOM <PROG1,PROG2>,FSUBR
MATOM <POUR>,FSUBR
MATOM <ETRACE>,SUBR,1
MOBJT ID,SUBR,VPOPJ,1
MOBJT FUNCTION,FSUBR,CAR
MATOM <OR,AND>,FSUBR
MOBJT IF,FSUBR,IFF
MOBJT IFN,FSUBR,IFFN
MATOM <COND,SELECT>,FSUBR
MOBJT SELECTQ,FSUBR,SELEQ
MATOM <WHILE,UNTIL,REPEAT,ESCAPE,LESCAPE>,FSUBR
A.PROG=.-MEMAD
MATOM <PROG,GO>,FSUBR
MATOM <GOTO,RETURN>,SUBR,1
A.DO=.-MEMAD
MATOM <DO>,FSUBR
MATOM <CYCLE>,SUBR,0
MATOM <SOME,EVERY>,SUBR,2
MATOM <MAP,MAPT,MAPLIS>,SUBR,2
MATOM <MAPC,MAPCT,MAPCAR>,SUBR,2
MATOM <MAPS,MAPST,MAPSUB>,SUBR,2
MATOM <ANDF,ORF>,SUBR
; MEM OBJ : predicats recherche et modification tableaux.
A.ATOM=.-MEMAD
MATOM <ATOM>,SUBR,1
A.LITAT=.-MEMAD
MATOM <LITATOM,NOT,NULL>,SUBR,1
A.LSTP=.-MEMAD
MATOM <LISTP,BOUNDP>,SUBR,1
MATOM <EQP,NEQP,EQ,NEQ,EQUAL,NEQUAL,SORT,SAMEPN>,SUBR,2
MATOM <PUT,ADDPROP>,SUBR,3
MATOM <GET,GETL,REMPROP>,SUBR,2
A.AUTO=.-MEMAD
MATOM <AUTOLOAD,DE,DF,DG,DM,DMI,DMO,DMC>,FSUBR
MATOM <TYPEP,TYPEFN,TYPNUMB,CAR,CDR>,SUBR,1
MATOM <CAAR,CADR,CDAR,CDDR>,SUBR,1
MATOM <CAAAR,CAADR,CADAR,CADDR>,SUBR,1
MATOM <CDAAR,CDDAR,CDADR,CDDDR>,SUBR,1
MATOM <CAAAAR,CAAADR,CAADAR,CAADDR>,SUBR,1
MATOM <CADAAR,CADADR,CADDAR,CADDDR>,SUBR,1
MATOM <CDAAAR,CDAADR,CDADAR,CDADDR>,SUBR,1
MATOM <CDDAAR,CDDADR,CDDDAR,CDDDDR>,SUBR,1
MATOM <MEMQ,MEMBER,NTH,CNTH,LAST>,SUBR,2
MATOM <ASSQ,ASSOC,CASSQ,CASSOC>,SUBR,2
MOBJT PUSH,SUBR,APUSH
MOBJT POP,SUBR,APOP,1
MATOM <PSTACK>,SUBR,1
MATOM <SET>,SUBR
MATOM <SETQ,SETQQ>,FSUBR
MATOM <RPLACA,RPLACD,SYNONYM>,SUBR,2
MATOM <RPLACB>,SUBR,2
MATOM <EXCH,NEXTL,NEWL>,FSUBR
MATOM <SMASH,FREVERSE>,SUBR,1
MATOM <ATTACH,NCONC>,SUBR,2
MATOM <NCONC1>,SUBR
MATOM <INCR,DECR>,FSUBR
A.CONS=.-MEMAD
MATOM <CONS>,SUBR,2
MATOM <XCONS,DCONS>,SUBR,2
A.NCONS=.-MEMAD
MATOM <NCONS>,SUBR,1
MATOM <COPY>,SUBR,1
A.LIST=.-MEMAD
MATOM <LIST>,SUBR
A.MCONS=.-MEMAD
MATOM <MCONS,LINEAR>,SUBR
MATOM <SUBLIS>,SUBR,2
MATOM <SUBST,PAIRLIS>,SUBR,3
MATOM <REVERSE,DELQ,DELETE,APPEND>,SUBR,2
MOBJT APPEND1,SUBR,APPED1
MATOM <EXPLODE,GENSYM>,SUBR
MATOM <LIT>,SUBR,3
MATOM <ASCII,CASCII>,SUBR,1
MATOM <OBLIST>,SUBR,0
MATOM <DA>,SUBR,3
MOBJT SETA,SUBR,ASTORE,3
MATOM <MAPARRAY,FILLARRAY>,SUBR,2
MATOM <DIM,LISTARRAY>,SUBR,1
MOBJT SETQA,FSUBR,STOREQ
MOBJT MAPARRAYQ,FSUBR,MAPARQ
; MEM OBJ : nombres et chaines.
A.NUMBP=.-MEMAD
MATOM <NUMBP,INUMBP,FLOATP,FIXP>,SUBR,1
MATOM <ZEROP,NEROP,LZP,GZP>,SUBR,1
MATOM <LEZP,GEZP,EVENP,ODDP>,SUBR,1
MATOM <DIVP,EQN,NEQN>,SUBR,2
MATOM <LT,LE,GT,GE>,SUBR
MATOM <LENGTH,PLENGTH>,SUBR,1
MATOM <ADD1,SUB1,MINUS,ABS,COMPL,SWAP>,SUBR,1
MATOM <PLUS,DIFFER,TIMES,QUO>,SUBR
MATOM <REM,MIN,MAX,BOOLE>,SUBR
MATOM <LOGAND,LOGOR,LOGXOR,LOGSHIFT>,SUBR,2
A.FIX=.-MEMAD
MATOM <FIX>,SUBR,1
A.FLO=.-MEMAD
MATOM <FLOAT>,SUBR,1
A.FAD1=.-MEMAD
MOBJT 1+,SUBR,FADD1,1
A.FSB1=.-MEMAD
MOBJT 1-,SUBR,FSUB1,1
A.FADD=.-MEMAD
MOBJT +,SUBR,FADD,2
A.FSUB=.-MEMAD
MOBJT -,SUBR,FSUB,2
A.FTIM=.-MEMAD
MOBJT *,SUBR,FTIM,2
A.FQUO=.-MEMAD
MOBJT /,SUBR,FQUO,2
A.FREM=.-MEMAD
XWD UNDEF,NIL ; C-val ,, P-liste
BYTE (7)1,"\" ; Pname 1
EXP 0 ; Pneme 2
EXP 0 ; Pname 3
XWD 3,.-MEMAD-12 ; type SUBR2 ,, atome suivant.
XWD SUBR,FREM ; indic ,, adresse.
A.PUISS=.-MEMAD
MOBJT **,SUBR,PUISS,2
A.FEQ=.-MEMAD
MOBJT =,SUBR,FEQ,2
A.FNEQ=.-MEMAD
MOBJT #,SUBR,FNEQ,2
A.FGT=.-MEMAD
XWD UNDEF,NIL ; C-VAL ,, P-LIST
BYTE (7)1,">" ; PNAME 1
Z ; PNAME 2
Z ; PNAME 3
XWD 3,.-MEMAD-12 ; type 2SUBR ,, A-LINK
XWD SUBR,FGT ; typefn ,, adr fnt.
A.FGE=.-MEMAD
XWD UNDEF,NIL ; C-VAL ,, P-LIST
BYTE (7)2,">","=" ; PNAME 1
Z ; PNAME 2
Z ; PNAME 3
XWD 3,.-MEMAD-12 ; type 2SUBR ,, A-LINK
XWD SUBR,FGE ; typefn ,, adr fnt.
A.FLE=.-MEMAD
XWD UNDEF,NIL ; C-VAL ,, P-LIST
BYTE (7)2,"<","=" ; PNAME 1
Z ; PNAME 2
Z ; PNAME 3
XWD 3,.-MEMAD-12 ; type 2SUBR ,, A-LINK
XWD SUBR,FLE ; typefn ,, adr fnt.
A.FLT=.-MEMAD
XWD UNDEF,NIL ; C-VAL ,, P-LIST
BYTE (7)1,"<" ; PNAME 1
Z ; PNAME 2
Z ; PNAME 3
XWD 3,.-MEMAD-12 ; type 2SUBR ,, A-LINK
XWD SUBR,FLT ; typefn ,, adr fnt.
MOBJT SQRT,SUBR,FSQRT,1
MOBJT SIN,SUBR,FSIN,1
MOBJT COS,SUBR,FCOS,1
MOBJT ATAN,SUBR,FATAN,1
MOBJT EXP,SUBR,FEXP,1
MOBJT LOG,SUBR,FLOG,1
MOBJT LOG10,SUBR,FLOG10,1
MATOM <RANDOM>,SUBR,0
MOBJT STRING,SUBR,STRGF,1
MOBJT MAKLIST,SUBR,MLSTRG,1
A.STRIP=.-MEMAD
MOBJT STRINGP,SUBR,STRINP,1
MOBJT NULLSTRP,SUBR,NSTRGP,1
MOBJT EQSTRING,SUBR,EQSTRG,2
MOBJT STRINGL,SUBR,STRGLE,1
A.INDEX=.-MEMAD
MOBJT INDEX
MATOM <CONCAT>,SUBR
MOBJT REVERSTR,SUBR,REVSTR,1
MATOM <DUPL>,SUBR,2
MATOM <TRANSLATE,SUBSTRING>,SUBR,3
MOBJT READSTR,SUBR,READST,0
; MEM OBJ : fonctions systeme speciales.
MOBJT DDT,SUBR,ADDT
MOBJT RESET,SUBR,ARESET,1
MATOM <LOC,VAG,PATCH>,SUBR,2
MATOM <IRCAMP>,SUBR,0
MOBJT TIME,SUBR,ATIME,0
MOBJT DATE,SUBR,ADATE,0
MATOM <VERSION>,SUBR,0
MATOM <STATUS>,SUBR
MATOM <GETPPN,PJOB,SWITCH,RUNTIME,DAYTIME>,SUBR,0
MATOM <LIGHTS>,SUBR,1
MATOM <GETTAB>,SUBR,2
MATOM <BREAK>,FSUBR
MOBJT ERROR,FSUBR,ERUS
MATOM <CONFIGURATION>,SUBR
A.RUBV=.-MEMAD
MOBJT ERROR.UBV,SUBR,ERA8
A.RUFE=.-MEMAD
MOBJT ERROR.UDFE,SUBR,ERA9
A.RUFA=.-MEMAD
MOBJT ERROR.UDFA,SUBR,ERA2
IFN %PISYS,<
A.ESCI=.-MEMAD
MOBJT ESCAPE.I,SUBR,FESCI,1
> ; IFN %PISYS
IFN %DAC,<
MOBJT DACSET,SUBR,ADACSET,1
MOBJT DACCHN,SUBR,ADACCHN,1
MOBJT DACFIL,SUBR,ADACFIL,1
MOBJT DACRAT,SUBR,ADACRAT,1
MOBJT DACOUT,SUBR,ADACOUT,1
MOBJT DACS,SUBR,ADACS,2
> ; IFN %DAC
; MEM OBJ : fonctions du LAP et AUTOLOAD.
A.OPCD=.-MEMAD
MATOM <OPCD>,SUBR,1
A.REGISTER=.-MEMAD
MATOM <REGISTER>,SUBR,1
A.VALAP=.-MEMAD
MATOM <VALAP>,SUBR,1
MATOM <GETSYMBOL>,SUBR,1
MATOM <LOADCODE>,SUBR,3
A.LAP1=.-MEMAD
MOBJT LAP1
A.DEBUG=.-MEMAD
MOBJT DEBUG
MAUTO <TRACE,UNTRACE,STEP,UNSTEP>,A.DEBUG
A.PRETTY=.-MEMAD
MAUTO <PRETTY,PRETTYP,PRETTYFILE,PRETTYF,PRETTYSIZE>,A.PRETTY
MAUTO <CROSSFILE,CROSSF>,A.PRETTY
; INDEX est deja le nom d'une fonction std (voir les chaines).
MAUTO <INDEXF,INDEXFILE>,A.INDEX
A.LAPACK=.-MEMAD
MAUTO <LAPACK,LAPACKF,LAPACKFILE>,A.LAPACK
A.LODLAP=.-MEMAD
MOBJT LODLAP
MAUTO <LAP,LAPFILE,LAPF>,A.LODLAP
A.COMPIL=.-MEMAD
MOBJT COMPIL
MAUTO <COMPILE,COMPILES,COMPILEFILE,COMPILEF>,A.COMPIL
MAUTO <COMPILOPTIONS,COMPILINDIC>,A.COMPIL
A.GREDIT=.-MEMAD
MOBJT GREDIT
MAUTO <GREDITF,GREDITV>,A.GREDIT
A.PHENAR=.-MEMAD
MOBJT PHENAR
MAUTO <PHENARETE,PHENARETES,PHENARETEFILE>,A.PHENAR
; le dernier atome doit etre toujours STOP ;
MATOM <STOP>,SUBR
MEMAF=.
IFN 0,<
BLOCK MEMAX-MEMAF+MEMAD
; zones PILE - PILE UTILISATUEUR - CODE
PILE: BLOCK N.STAK ; zone pile.
USTCK: BLOCK N.USTK
BCODE: BLOCK N.CODE ; zone code.
>
SUBTTL Initialisation, Configuration.
RELOC 400000
; S T A R T
JRST ARESET+1 ; pour le .ST +1
START::
TDZA A5,A5 ; non CCL entry.
MOVEI A5,1 ; CCL entry.
MOVEM A5,CCL
RESET
MOVEI A5,REENT ; init de l'@ de .REE
HRRZM A5,.JBREN
MOVEI A5,INTBLK ; adresse du ↑C intercept.
HRRZM A5,.JBINT
MOVE A5,[PUSHJ P,ERUUO]
MOVEM A5,.JB41 ; init trap UUO.
IFN 0,<
OUTSTR [ASCIZ /VLISP 10-3
/]
>
;;; initialisation du page printer.
PPIOT 0,1 ; PPSEL 1 : selction Page 1.
JFCL
; [SAILPATCH]
; old: PPIOT 3,012002
; i.e. 10 glitches de 2 lignes.
; new:
PPIOT 3,004011 ; 4 glitches de 9 lignes.
JFCL
PPIOT 6,0 ; LEYPOS normale en bas.
JFCL
; INITP doit suivre...
; configuration (initialisation des pointeurs) ;
INITP: AOSLE ONCEFG ; c'est la 1ere fois ?
JRST START1 ; nan : vers depart chaud.
; oui : init des pointeurs.
SETZ A5, ; debut index in MEM.
MOVE A6,C.ATOM ; calcul de la taille de la zone atome.
IMULI A6,SIZAT
ADD A5,A6
MOVEM A6,BNUMB ; BNUMB.
ADD A5,C.NNUM
MOVEM A5,PZER ; PZER.
ADD A5,C.PNUM
MOVEM A5,BCNUM ; BCNUM.
MOVE A6,C.NUMB
IMULI A6,2
ADD A5,A6
MOVEM A5,BSTRG ; BSTRG
ADD A5,C.STRG
MOVEM A5,BLIST ; BLIST.
ADD A5,C.LIST
MOVEM A5,ELIST ; ELIST.
TRNE A5,600000 ; y fo ps depasser 64k en zone relative
JRST SPCERR ; car le GC utilise le bit 20000
ADDI A5,MEMAD ; passage en adresse absolue.
MOVEM A5,BPILE ; BPILE.
SUBI A5,1 ; preparation du IOWD pile.
MOVN A6,C.STAK
HRL A6,A6
HRR A6,A5 ; == IOWD -N.STACK,PILE
MOVEM A6,PILINI ; PILINI.
ADD A5,C.STAK
MOVEM A5,USTCKB ; USTCKB.
MOVEM A5,USTCKC ; USTCKC.
ADD A5,C.USTK
MOVEM A5,USTCKE
MOVEM A5,USTCKF
ADDI A5,1
MOVEM A5,BCODEB
MOVEM A5,BCODEC
ADD A5,C.CODE
MOVEM A5,BCODEE
MOVEM A5,MEMEND
MOVE A6,A5 ; pour positionner .JBFF
CORE A5, ; demande la place.
JRST SPCERR
JRST INITZ ; vers l'initialisation des zones.
SPCERR: ;;; ya pas assez de place.
RESET ; pour voir la page 0.
OUTSTR [BYTE (7)15,12,"*","*"," "
ASCIZ / not enough core.../]
EXIT
; configuration (initialisation des zones) ;
INITZ:
MOVE A5,.JBFF
CAME A5,A6
HRRM A6,.JBFF
;;; SAUVE LES POINTEURS.
MOVE A5,.JBREL ; sauve les pointeurs
HRL A5,.JBFF ; memoire.
MOVEM A5,INICOR
;;; initialisation des atomes systemes.
MOVEI A1,NIL ; le 1er c'est NIL j'le sais.
MOVEI A5,-1 ; marqueur fin liste.
ST00:
HRRM A5,MEM+4(A1) ; met le LINK.
MOVEI A5,(A1) ; actualise l'@.
ADDI A1,SIZAT ; atome suivant.
CAMGE A1,SATOM ; c'est fini ?
JRST ST00 ; nan.
MOVEM A5,CATOM ; positionne le point courant atomes.
;;; initialisation liste des atomes libres.
MOVEI A5,-1 ; fin de la liste des atomes.
MOVE A6,SATOM
JRST ST11
ST10:
HRRM A5,MEM+4(A6)
MOVEI A5,(A6)
ADDI A6,SIZAT
ST11:
CAMGE A6,BNUMB
JRST ST10
MOVEM A5,FATOM
;;; initialisation des nombres fixes.
MOVE A1,BNUMB ; init NUM FIX.
MOVN A2,C.NNUM
ST20:
MOVEM A2,MEM(A1)
ADDI A1,1
CAMGE A1,BCNUM
AOJA A2,ST20
JRST START0
; init GC PATHLIBRARY et depart a chaud.
START0: ;;; depart a froid.
MOVEI A5,ININI ; prep lecture CONFIG.INI
MOVEM A5,INSTRT
JRST START2
START1: ;;; depart a chaud.
MOVE A5,INICOR ; restore des point memoire.
HLRZM A5,.JBFF ; (cf : RESET T)
TLZ A5,-1
CAME A5,.JBREL
CORE A5,
JFCL
MOVEI A5,INSTD ; entree tout de suite standard.
MOVEM A5,INSTRT
START2:
MOVE P,PILINI ; init de la pile.
GETPPN A5, ; recup PPN user.
JFCL
MOVEM A5,MYPPN
MOVEM A5,LIB$PA ; init PATHLIBRARY avec MYPPN.
PJOB A5, ; recup no du job.
MOVEM A5,PNJOB
MOVE A5,[' 1 3'] ; [SAILPATCH] Sep 11 78.
MOVEM A5,LIB$PA+1 ; init PATHLIBRARY avec SYS:
SETOM LIB$PA+2 ; fin table PATHLIB.
MOVE RG,[RGSTD] ; standard R.G.
SETZ A1, ; NIL <- A1.
MOVEI A4,A.TOPLV ; init TOP-LEVEL.
PUTCDR A4,A1
MOVEI A4,A.EOF ; init EOF.
PUTCDR A4,A1
MOVSI A5,-<GC.END-GC.BEG> ; initialise tous les compteurs
SETZM GC.BEG(A5) ; du GC
AOBJN A5,.-1
SETZM GC.TTT ; RAZ temps total in GC.
MOVE A5,PNJOB ; base du runtime sous LISP.
RUNTIME A5,
MOVEM A5,GC.TTI
SETZB A1,A2 ; RAZ LES REGS GARBEAGEABLES.
SETZB A3,A4 ; IDEM.
PUSHJ P,GARBCY ; init liste libre.
PUSHJ P,OUTSTD ; OUTPUT standard.
PUSHJ P,@INSTRT ; chaud / froid (INSTD / ININI)
; l'init du PSYS doit suivre ...
; configuration (initialisation du systeme d'interruptions).
IFN %PISYS,<
MOVEI A5,VECTOR ; adresse du vecteur d'interruptions.
PIINI. A5, ; avec l'UUO ad hoc.
JRST PISERR ; ca va mal.
MOVSI A5,(1B2) ; turn on PISYS.
PISYS. A5, ; lance.
JRST PISERR ; ca va encore plus mal.
MOVE A5,[4000,,PDLBLK] ; rajoute l'IT pdl ovl.
; PS.ADV == PS.FAC.
PISYS. A5, ; toujours avec l'UUO ad hoc.
JRST PISERR ; ca s'arrange pas
MOVE A5,[4000,,BESCPI] ; rajoute l'IT escape-I.
PISYS. A5,
JRST PISERR ; a voir ...
MOVE A5,[4000,,ARIBLK] ; rajoute l'IT arith. overflow.
PISYS. A5,
JRST PISERR ; bon bon...
MOVE A5,[4000,,IRMBLK] ; rajoute l'IT ill ref mem.
PISYS. A5,
JRST PISERR
JRST REENT ; c'est tout bon .
PISERR: ; le systeme va pas.
MOVEI A6,VECTOR ; pour pouvoir voir avec des .Examine ...
HALT INITP ; pour le .CONT
> ; IFN %PISYS
JRST REENT ; [SAILPATCH] Sep 11
; (CONFIGURATION init inp outp ....) [NSUBR]
TCONF: MEXP C.ATOM,C.NUMB,C.STRG,C.LIST,C.STAK,C.USTK,C.CODE
CONFIGURATION:
;;; INITIAL.
JNLIST A4,CONF9 ; ya rien a configurer.
UNCONS A4,A1,A4 ; A1 <- specif initial.
JPNIL A1,CONF1
PUSH P,A4 ; sauve le reste.
PUSHJ P,GETSPC ; convertit la specification.
SKIPE A5,GTF$DV ; recup le device.
MOVEM A5,FL.INI
SKIPE A5,GTF$FL ; recup le filname.
MOVEM A5,FL.INI+1
SKIPE A5,GTF$EX ; recup l'extension.
MOVEM A5,FL.INI+2
POP P,A4 ; recup le reste des args.
CONF1: ;;; INPUT.
JNLIST A4,CONF9 ; fin de la config.
UNCONS A4,A1,A4 ; A1 <- specif input.
JPNIL A1,CONF2
PUSH P,A4 ; sauve le reste.
PUSHJ P,GETSPC ; convertit la specification.
SKIPE A5,GTF$DV ; recup le device.
MOVEM A5,FL.INP
SKIPE A5,GTF$FL ; recup le filename.
MOVEM A5,FL.INP+1
SKIPE A5,GTF$EX ; recup l'extension.
MOVEM A5,FL.INP+2
POP P,A4 ; rest le reste des args.
CONF2: ;;; OUTPUT.
JNLIST A4,CONF9 ; fin de la config.
UNCONS A4,A1,A4 ; A1 <- specif output.
JPNIL A1,CONF3
PUSH P,A4 ; sauve le reste des args.
PUSHJ P,GETSPC ; convertit la specification.
SKIPE A5,GTF$DV ; recup le device.
MOVEM A5,FL.OUT
SKIPE A5,GTF$FL ; recup le filename.
MOVEM A5,FL.OUT+1
SKIPE A5,GTF$EX ; recup l'extension.
MOVEM A5,FL.OUT+2
POP P,A4 ; rest le reste des args.
CONF3: ;;; init de la taille des zones.
MOVSI A6,-7 ; init AOBJN point.
CONF4:
JNLIST A4,CONF9 ; fin de la configuration.
UNCONS A4,A1,A4 ; A1 <- nb suivant.
JPNIL A1,CONF5 ; on ne modifie rien.
MOVE A5,MEM(A1) ; recup la valeur.
MOVEM A5,@TCONF(A6) ; charge le nb.
CONF5: ; au suivant.
AOBJN A6,CONF4 ; yen a encore.
CONF9: ;;; fin de la configuration.
JRST START ; on recommence tout.
; ↑C intercept + pdl ovfl + arith ovfl
; ↑C INTERCEPT : ce n'est pas un veritable TRAP
; mais juste un avertissement en cas de G.C.
INTLOC:
MOVEM 1,INTBLK+4 ; SAVE AC1.
HLRZ 1,INTBLK+3 ; RECUP CAUSE.
CAIE 1,2 ; ↑C ?
HALT . ; NON ! HORREUR !!
SNBIT IBIT35 ; SI NON IN G.C. .
OUTSTR [ASCIZ /
↑ G.C. ↑ type .CONT please ...
/]
EXIT 1, ; APPEL MONITEUR.
MOVE 1,INTBLK+2 ; RECUP RETURN ADRESS.
EXCH 1,INTBLK+4 ; RESTORE AC.
PUSH P,INTBLK+2 ; SAUVE ADR RETOUR.
SETZM INTBLK+2 ; PREPARE NOUVEL INTERUPT.
POPJ P, ; CA CONTINUE.
; Traitement de l'IT pdl ovl
IFN %PISYS,<
ERPDL: ;;; pdl ovl.
JNBIT IBIT35,ERPDL1
PUSH P,[POINT 7,[BYTE (7)↑D31,15,12," "," "
ASCIZ /** pdl overflow during G.C./],6]
JRST ERPDL2
ERPDL1:
PUSH P,[POINT 7,[BYTE (7)↑D32,15,12," "," "
ASCIZ /** pdl overflow at user PC :/],6]
ERPDL2:
MOVE A1,VECTOR+5 ; old PC pour l'impression.
MOVEI A5,ERRPA1 ; pour imprimer A1 puis .REE
MOVEM A5,VECTOR+5 ; in old PC.
DEBRK. ; acquit.
HALT . ; on sait jamais.
>
; Traitement de l'IT arith exception.
IFN %PISYS,<
EROVFL: ;;; arith ovl.
PUSH P,[POINT 7,[BYTE (7)↑D32,15,12," "," "
ASCIZ /** arithmetic exception. PC :/],6]
MOVE A1,VECTOR+↑D13 ; A1 = program control.
MOVEI A5,ERRPA1 ; vers l'impression simple du libelle.
MOVEM A5,VECTOR+↑D13 ; in old PC.
DEBRK.
HALT . ; on sait jamais.
>
; TRAP GC ET ILL. REF. MEMORY
IFN %PISYS,<
ERILRM: ;;; ill ref. memory.
IFN %TRPGC,<
PUSH P,A5 ; libere 2 registres
PUSH P,A6 ; pour travailler.
HRRZ A5,VECTOR+↑D17 ; recup l'adresse de trap.
MOVE A6,(A5) ; recup l(instruction qui l'a provoque.
AND A6,[EXCH 0,MEM(FREE)] ; c'etait la 1ere instruction
CAME A6,[EXCH 0,MEM(FREE)] ; d'un CONS de liste ?
JRST ERILR2 ; nan : vraie erreur.
MOVE A6,1(A5) ; recup 2eme intruction apres trap.
AND A6,[EXCH FREE,] ; c'eatit une 2eme instruction
CAME A6,[EXCH FREE,] ; d'un CONS de liste ?
JRST ERILR2 ; nan : vraie erreur.
;;; c'est donc la fin de la liste libre.
POP P,A6 ; restaure A6.
MOVEI A5,GARBCL ; pour simuler un
EXCH A5,VECTOR+↑D17 ; PUSHJ P,GARBCL
EXCH A5,(P) ; avant le EXCH x,MEM(FREE)
DEBRK.
HALT . ; on sait jamais.
> ; de %TRPGC
ERILR2: ;;; EN CAS DE VERITABLE ERREUR.
PUSH P,[POINT 7,[BYTE (7)↑D34,15,12," "," "
ASCIZ /** ill ref memory at user PC :/],6]
MOVE A1,VECTOR+↑D17 ; recup le PC.
MOVEI A5,ERRPA1 ; prepare une erreur avec impression de A1.
MOVEM A5,VECTOR+↑D17 ; in old PC.
DEBRK.
HALT .
> ; de %PISYS
; interrupt ESCAPE-I
IFN %PISYS,<
TESCI:
;;; 1ere methode : interruptions vraies.
; mais qu faire en cas de G.C.
; MOVEI A5,ESCI ; il suffit d'aller en ESCI.
; PUSH P,VECTOR+9 ; sauve old PC pour retour ESCI.
; MOVEM A5,VECTOR+9 ; (in old PC).
; DEBRK.
; HALT .
;
;ESCI:
; PUSH P,A1 ; sauve tout !
; PUSH P,A2
; PUSH P,A3
; PUSH P,A4
; PUSH P,A5
; PUSH P,A6
; PUSH P,A7
; PUSH P,A8
; PUSH P,L
; HRRZ A5,VECTOR+↑D11 ; recupere le n0 qui a ete tape.
; PUSHJ P,CRANUM ; A1 :- le nb.
; MOVEI A4,(A1) ; A4 :- le nom (pour APPLY).
; MOVEI A1,A.ESCI ; A1 le nom de la fonction.
; PUSHJ P,APPLYL ; c'est PARTI.
; POP P,L
; POP P,A8
; POP P,A7 ; il faut creer un block non garbageable
; POP P,A6 ; dans la pile !!!!!
; POP P,A5
; POP P,A4
; POP P,A3
; POP P,A2
; POP P,A1
; POPJ P, ; tombe sut l'adresse sauvee en TESCI.
; i.e. old PC.
;;; 2eme methode : positionner un flag pour EVALHOOK.
SETBIT IBIT33 ; indicateur pour EVALHOOK.
MOVEM A5,NESCPI ; sauve le no du ESC-I,
HRRZ A5,VECTOR+↑D11 ; sans detruire aucun
EXCH A5,NESCPI ; registre!
DEBRK. ; et c'est tout ce qui a a faire.
HALT . ; ca peut jamais arriver.
FESCI: ;;; fonction ESCAPE.I standard.
PUSH P,A1 ; sauve le nb argument.
MOVE A6,[POINT 7,[BYTE (7)↑D20,15,12," "," "
ASCIZ /** Escape-I : /],6]
PUSHJ P,PRBPN ; qu'on edite.
POP P,A1 ; recup le nb.
PJRST PRINT ; impression et retour.
EVALEI: ;;; appeller par EVAL si le bit 33
; est mis.
CLRBIT IBIT33 ; enleve le bit d'IT.
PUSH P,A1 ; sauve l'argument de EVAL.
PUSH P,[EVALER] ; retour APRES APLY.
MOVEM A1,LFORME ; pour avoir A1 en 2eme argument.
PUSH P,[-1,,A.ESCI] ; pour ERRSYN.
HRRZ A5,NESCPI ; recupere le n0 qui a ete tape.
PUSHJ P,CRANUM ; A1 :- le nb.
PUSH P,A1 ; 1eme arg : numero de Escape-I.
JRST ERRSYS ; (apply escape.i no a1 p p$bind ...)
EVALER: ;;; retour apres APPLY.
POP P,A1 ; recupere l'argument de EVAL.
JRST EVAL ; comme si de rien n'etait.
>
; RESET REENT
; (RESET [T]) - SUBR -
; SI [T] REINITIALISATION DES BUFFERS I/O/D/L.
ARESET::
; si ya T (y fo unbinder toute la pile).
MOVE P,PILINI ; dans tous les cas on restaure la pile.
RESET
MOVE A5,INICOR ; RESTORE MEMORY.
HLRZM A5,.JBFF
TLZ A5,-1
CAME A5,.JBREL
CORE A5, ; JPEUX EN RECUPERER.
JFCL
OUTSTR [ASCIZ /RESET
/]
JRST START1 ; vers le depart a chaud...
; POUR .REENTER OU ERREUR .
REENT::
OUTSTR [ASCIZ /.REE/] ; Pour faire vraiment tres chic.
MOVE P,PILINI ; INIT POINTEUR PILE.
PUSHJ P,OUTBUF ; VIDE BUFFER SORTIE.
SETZB A1,A2 ; RAZ LES REGS GARBAGEABLES.
SETZB A3,A4 ; IDEM.
PUSHJ P,GARBCY ; LANCE UN G.C. (A CAUSE DES CONTROLS C).
MOVEMM USTCKB,A5,USTCKC ; INIT USER STACK.
SETZM LFORME ;?!? ya parfois d'etranges choses
; dans LFORME qqui ont ete Garbagees....
REENT1:
CLRBIT IBIT30!IBIT31!IBIT32 ; RAZ into LIBRARY, into READ.
; into IMPLODE.
SETZM DPREAD ; RAZ profondeur du READ.
SETOM P$BIND ; le 1er P$BIND = [-1,,-1].
SETZ A4, ; pour APPLY.
MOVEI A1,A.TOPLV ; (APPLY 'TOPLEVEL NIL)
PUSHJ P,APPLY
JRST REENT1
; TOP-LEVEL
; TOP - LEVEL standard.
; appelle par REEENT dans (WHILE T (TOPLEVEL))
; --NEW-- le valeur ramenee par le top-level est
; toujours stockee dans l'atome IT.
TOPLEVEL::
PUSHJ P,READU ; lit la S-expression.
JNBIT IBIT2,TOPLE1 ; y fo imprimer les reads ?
MOVEMM PREFOR,A7,PRPREF; positionne prefixe read "?".
PUSHJ P,PRINT ; on imprime la forme lue.
TOPLE1:
MOVEMM PREFPR,A7,PRPREF; positionne prefixe print " ".
JNBIT IBIT0,TOPLE2 ; il fo imprimer l'eval-time.
MOVE A7,PNJOB ; EVAL TIME.
RUNTIME A7,
MOVEM A7,EVTIME
TOPLE2:
PUSHJ P,EVAL
HRLM A1,MEM+A.IT ; sauve la val dans IT.
JNBIT IBIT1,VPOPJ ; pas d'impression du TOP-LEVEL.
JNBIT IBIT0,TOPLE3
MOVE A7,PNJOB
RUNTIME A7, ; EVAL TIME.
SUB A7,EVTIME
MOVEM A7,EVTIME
TOPLE3:
MOVEMM PREFTO,A7,PRPREF ; met le prefixe toplevel '='.
PUSHJ P,PRINT
JNBIT IBIT0,TOPLE4 ; y fo pas imprimer EVAL-TIME.
MOVE A6,[POINT 7,[ASCIZ / ; time = /]]
PUSHJ P,PRBPN
MOVE A7,EVTIME
PUSHJ P,CONVD0 ; toujours en deimal.
PUSHJ P,PRBPN
MOVE A6,[POINT 7,[ASCIZ / ms ;/]]
PUSHJ P,PRBPN
PUSHJ P,OUTBUF
TOPLE4:
MOVEMM PREFPR,A7,PRPREF ; remet le prefixe print ' '.
POPJ P,
SUBTTL GARBAGE-COLLECTING
$$GC::
PRINTX /3-G.C./
; GARBPR: IMPRIME UNE VALEUR DU G.C.
; SUPPOSE LE NB EMPILE, UNE CHAINE DANS A6.
GARBPR:
PUSHJ P,PRBPN ; EDITE LA CHAINE.
MOVEI A5,25 ; (TTAB 21).
MOVEM A5,BUFOUP
MOVE A6,[POINT 7,[BYTE (7)3," ",":"," "],6]
PUSHJ P,PRBPN
POP P,A7 ; DEPILE LE NB.
EXCH A7,(P)
PUSHJ P,CONVD0 ; le convertit.
PUSHJ P,PRBPN ; L'EDITE.
JRST OUTBUF ; VIDE LE BUFFER.
; GARBPT : imprime plusieurs valeurs.
; suppose empiles : SIZE, MARKED, FREED.
GARBPT:
MOVEI A5,4 ; (TTAB 4).
MOVEM A5,BUFOUP
PUSHJ P,PRBPN ; edite le libelle (dans A6).
MOVEI A5,21
MOVEM A5,BUFOUP ; (TTAB 16)
MOVE A6,[POINT 7,[BYTE (7)7,"s","i","z","e"
ASCIZ / : /],6]
PUSHJ P,PRBPN
POP P,A7 ; @ de retour.
EXCH A7,-2(P) ; EXCH AVEC SIZE.
PUSHJ P,CONVD0 ; convertit size.
PUSHJ P,PRBPN ; EDITE SIZE.
MOVEI A5,40
MOVEM A5,BUFOUP
MOVE A6,[POINT 7,[BYTE (7)11,"m","a","r","k"
ASCIZ /ed : /],6]
PUSHJ P,PRBPN
POP P,A7 ; depile 'MARKED'
PUSHJ P,CONVD0 ; convertit marked.
PUSHJ P,PRBPN
MOVEI A5,60
MOVEM A5,BUFOUP
MOVE A6,[POINT 7,[BYTE (7)10,"f","r","e","e"
ASCIZ /d : /],6]
PUSHJ P,PRBPN
POP P,A7 ; depile 'FREED '
PUSHJ P,CONVD0 ; convertit freed.
PUSHJ P,PRBPN
PJRST OUTBUF
; G.C. : GARBCOLL (entries)
GARBCY: ; GC dus au systeme.
AOS GC.NGY
JRST GARBCG
GARBCN: ; GC dus aux nombres.
AOSA GC.NGN
GARBCA: ; GC dus aux atomes.
AOS GC.NGA
JRST GARBCG
GARBCS: ; GC dus aux chaines.
AOSA GC.NGS
GARBCL:: ; GC dus aux listes.
AOS GC.NGL
GARBCG:
PUSH P,A1 ; SAUVE LES REGISTRES GARBAGABLES.
PUSH P,A2
PUSH P,A3
PUSH P,A4
MOVE A1,[XWD 5,GARBSV] ; SAUVE LES AUTRES.
BLT A1,GARBSV+6 ; SAUF FREE,NUMB,STRG !!!!!!!
AOS GARBN ; INCR NUMERO G.C.
SOS GARBC ; DECR G.C. COUNT.
JNBIT IBIT5,GARB1 ; SPEAK G.C. ?
PUSHJ P,OUTBUF
PUSHJ P,OUTBUF
PUSH P,GARBN
MOVE A6,[POINT 7,[BYTE (7)13,"*","*","*","*"
ASCIZ /G.C. No/],6]
PUSHJ P,GARBPR
PUSHJ P,OUTBUF
PUSH P,GARBC
MOVE A6,[POINT 7,[BYTE (7)16," "," "," "," "
ASCIZ /G.C. count/],6]
PUSHJ P,GARBPR
; G.C. : marquage
; Marquage : durant tout le marquage ,
; A8 contient le bit de GC (200 000)
; A7 contient SATOM (limite des atomes systemes)
GARB1:
MOVE A5,PNJOB ; sauve le temps de depart.
RUNTIME A5,
MOVEM A5,GARBT
SETBIT IBIT35 ; INTO G.C. !
SETZM GARBM ; RAZ NB MARKED
SETZB A8,GARBA
TXO A8,BITGC ; A8 CONTIENDRA TOUJOURS CA !
MOVE A7,SATOM ; charge SATOM ds un reg (pour le temps)
;;; marquage de la pile systeme
HRRZM P,GARBP ; SAVE CIRRENT STACK.
MOVE A4,BPILE ; INIT BEGIN STACK.
MARKP1:
CAMLE A4,GARBP ; TOP-STACK ?
JRST MARKUS ; OUI.
HRRZ A1,(A4) ; LE CDR
CAML A1,ELIST
AOJA A4,MARKP1 ; EST UNE @ SYSTEME ET
HLRZ A1,(A4) ; LE CAR
CAML A1,ELIST
AOJA A4,MARKP1 ; AUSSI.
CAIL A1,(A7) ; les atomes systeme ne se GC pas.
PUSHJ P,MARK ; LE CAR EST UNE LISTE (A KOSE DES MOVS'S).
HRRZ A1,(A4)
CAIL A1,(A7) ; les atomes systeme ne se GC pas.
PUSHJ P,MARK ; LE CDR EST UNE LISTE.
AOJA A4,MARKP1
MARKUS: ;;; marquage de la pile utilisateur
MOVE A4,USTCKC
MARKU1:
CAMG A4,USTCKB ; FIN PILE ?
JRST MARKAR ; ouqip.
HRRZ A1,(A4)
CAIL A1,(A7) ; les atomes systemes ne se GC pas.
PUSHJ P,MARK ; C'EST UNE LISTE.
SOJA A4,MARKU1
MARKAR: ;;; marquage zone ARRAY.
MOVE A4,USTCKE ; debut zone tableaux.
MARKA1:
CAML A4,USTCKF ; fin zone tableaux ?
JRST MARKOB ; ouaip.
MOVE A1,(A4) ; recupere l'element de tableau.
CAIL A1,(A7) ; skip si atome systeme.
PUSHJ P,MARK ; on le marque.
AOJA A4,MARKA1 ; a l'element suivant.
MARKOB: ;;; marquage OBLIST.
MOVE A4,CATOM ; recup debut liste des atomes.
MARKO1:
GETCAR A4,A1 ; A1 <- C-val.
CAIL A1,(A7) ; c'est un atome systeme.
PUSHJ P,MARK ; sinon on la marque.
GETCDR A4,A1 ; A4 <- P-liste de l'atome.
JPNIL A1,.+2 ; elle est vide.
PUSHJ P,MARK ; sinon on la marque.
HRRE A4,MEM+4(A4) ; atome suivant.
JUMPGE A4,MARKO1 ; il en reste.
MARKMC: ;;; marquage table des macros-caracteres.
MOVEI A4,TABCAR ; debut de la table.
MARKM1:
CAIL A4,TABCAF ; fin table ?
JRST GARB4 ; ouaip.
HLRZ A1,(A4) ; recup @ macro.
JUMPE A1,.+2 ; yen a pas.
CAML A1,ELIST ; code ?
AOJA A4,MARKM1 ; c'est pas un objet LISP.
PUSHJ P,MARK ; sinon on marque.
AOJA A4,MARKM1
GARB4:
PUSHJ P,MAKFREE ; libere tout.
CLRBIT IBIT35 ; je suis plus dans le G.C.
;;; edite des statistiques.
MOVE A5,PNJOB
RUNTIME A5,
SUB A5,GARBT
MOVEM A5,GARBT ; temps ecoule durant ce G.C.
ADDM A5,GC.TTT ; calcule le temps total in G.C.
; G.C. : edition des statistiques.
JNBIT IBIT5,GARB5 ; ya pas le bit speak GC.
PUSH P,GARBA
MOVE A6,[POINT 7,[BYTE (7)21," "," "," "," "
ASCIZ /ALTERED CELLS/],6]
PUSHJ P,GARBPR
MOVE A5,ELIST ; calcul de la taille des listes.
SUB A5,BLIST
PUSH P,A5
PUSH P,GARBF
PUSH P,GARBM
MOVE A6,[POINT 7,[BYTE (7)5,"L","I","S","T"
ASCIZ /S/],6]
PUSHJ P,GARBPT
MOVE A5,BLIST ; calcul la taille des chaines.
SUB A5,BSTRG
PUSH P,A5 ; prepare l'impression.
PUSH P,GC.FST
PUSH P,GC.MST
MOVE A6,[POINT 7,[BYTE (7)7,"S","T","R","I"
ASCIZ /NGS/],6]
PUSHJ P,GARBPT
MOVE A5,BSTRG ; calcul la taille des nombres.
SUB A5,BCNUM
IDIVI A5,2 ; 2 mots/nb.
PUSH P,A5
PUSH P,GC.FNB
PUSH P,GC.MNB
MOVE A6,[POINT 7,[BYTE (7)7,"N","U","M","B"
ASCIZ /ERS/],6]
PUSHJ P,GARBPT
MOVE A5,BNUMB ; calcul taille atomes.
IDIVI A5,SIZAT
PUSH P,A5
SUB A5,GC.MAT
MOVEM A5,GC.FAT
PUSH P,A5
PUSH P,GC.MAT
MOVE A6,[POINT 7,[BYTE (7)5,"A","T","O","M"
ASCIZ /S/],6]
PUSHJ P,GARBPT
PUSH P,C.CODE ; taille de la zone code.
MOVE A5,BCODEE ; ce qui reste.
SUB A5,BCODEC
PUSH P,A5
MOVE A5,BCODEC ; ce qui est deja utilise.
SUB A5,BCODEB
PUSH P,A5
MOVE A6,[POINT 7,[BYTE (7)4,"C","O","D","E"
ASCIZ / /],6]
PUSHJ P,GARBPT
PUSH P,GARBT
MOVE A6,[POINT 7,[BYTE (7)16," "," "," "," "
ASCIZ /elapsed time/],6]
PUSHJ P,GARBPR
MOVE A6,[POINT 7,[BYTE (7)30," "," "," "," "
ASCIZ /average time in G.C. : /],6]
PUSHJ P,PRBPN ; edite la chaine.
GARB5:
MOVE A5,PNJOB
RUNTIME A5,
SUB A5,GC.TTI ; A7 temps total de l'intreprete.
MOVE A7,GC.TTT
IMULI A7,↑D100 ; pour les pourcentages.
IDIV A7,A5
PUSHJ P,CONVD0
IFN %IRCAM,<
MOVE A5,PRSTRG
TLZ A5,774000 ; enleve le nb de caracteres.
MOVEM A5,DMBUF+3
>
JNBIT IBIT5,GARB6
PUSHJ P,PRBPN ; edite le %.
MOVE A6,[POINT 7,[BYTE (7)3," ","%"],6]
PUSHJ P,PRBPN
PUSHJ P,OUTBUF
;;; fin des statistiques
GARB6:
IFN %IRCAM,< ; affiche GC NO et le pourcentage.
MOVE A7,GARBN ; recup le GC NO.
PUSHJ P,CONVD0 ; on le convertit.
MOVE A5,PRSTRG
TLZ A5,774000 ; enleve le nb de caracteres.
MOVEM A5,DMBUF+1 ; on le range.
MOVE A7,GARBF ; recup le nb de liste liberees.
PUSHJ P,CONVD0 ; on le convertit.
MOVE A5,PRSTRG ; recupere les 1ers digits.
TLZ A5,774000 ; enleve le nb de caracteres.
MOVEM A5,DMBUF+5 ; range les 1ers digits.
MOVE A5,PRSTRG+1 ; recupere les derniers digits.
MOVEM A5,DMBUF+6 ; on les range.
MOVE A7,GC.FAT ; recup le nb d'atomes libres.
PUSHJ P,CONVD0 ; on le convertit.
MOVE A5,PRSTRG ; recupere les digits decimaux.
TLZ A5,774000 ; enleve le nb de caracteres.
MOVEM A5,DMBUF+8 ; on les range.
SKIPE UPGIOB+2 ; l'ancien transfert est fini ?
JRST .-1 ; on attend et c'est pas beau ....
PPIOT 12,UPGIOB ; on affiche.
JFCL ; voila.
>
MOVE A1,GARBF
JUMPLE A1,ERFM ; ** ER FM .
CAMLE A1,GARBL
JRST GARB7 ; il en reste assez.
PUSHJ P,OUTBUF
MOVE A6,[POINT 7,[BYTE (7)21,15,12,"*","*"
ASCIZ /** left cells/],6]
PUSH P,GARBF
PUSHJ P,GARBPR
GARB7:
SKIPN GARBC
JRST ERGC ; ** ER STEP DONE.
MOVE A1,[XWD GARBSV,5]
BLT A1,13 ; REST A5,A6,A7,A8,U1,U2,L
POP P,A4 ; resaturation des registres garbageables.
POP P,A3
POP P,A2
POP P,A1
POPJ P,
; G.C. : MARK
; marque A1 . A8 contient tjrs le bit GC.
; ne doit pas toucher a A4 !
MARK::
CAML A1,ELIST ; OBJET LISP ?
JRST MARK9 ; NAN.
JNLIST A1,MARK4
;;; CAS DOUBLET DE LISTE.
TDNE A8,MEM(A1) ; EST-IL DEJA MARQUE ?
POPJ P, ; OUI : YA PU RIEN A FAIRE.
GETCAR A1,A3
CAML A3,BSTRG ; CAR ATOME OU NB ?
JRST MARK7 ; non : vers le taitement recursif.
CAML A3,BNUMB ; si litatom ou
CAML A3,BCNUM ; nombre cree,
IORM A8,MEM+1(A3) ; alors on marque.
MARK2:
IORM A8,MEM(A1) ; MARQUE LE DOUBLET.
AOS GARBM ; INCREMENTE LE NB DE MARQUAGE.
GETCDR A1,A1
JNNIL A1,MARK ; ITERE SUR LES CDRS.
POPJ P, ; FIN LISTE.
MARK4:
CAML A1,BSTRG
JRST MARK5
;;; cas atomes litteraux ou nombres.
CAML A1,BNUMB ; si vrais litatomes,
CAML A1,BCNUM ; ou nombres cres,
IORM A8,MEM+1(A1) ; alors on marque.
POPJ P,
MARK5: ;;; cas chaines.
MOVE A2,MEM(A1)
TXOE A2,BITGC ; MARK ET TEST.
POPJ P, ; IL ETAIT DEJA MARQUE.
MOVEM A2,MEM(A1) ; STORE LE MOT MARQUE.
HRRZ A1,A2 ; RECUP LA LISTE DES CARACTERES.
JNNIL A1,MARK ; ET ON LES MARQUENT.
POPJ P, ; SI CHAINE VIDE.
MARK7:
CAIN A1,(A3) ; AIDA: noeud dans le CAR !!
JRST MARK2 ; on evite donc de faire sauter la pile.
PUSH P,A1 ; SAUVE LA LISTE
MOVEI A1,(A3)
PUSHJ P,MARK ; RECURSE SUR LES CARS
POP P,A1
JRST MARK2 ; continue iterarif.
MARK9:
AOS GARBA ; incremente ALTERED CELL.
POPJ P, ; Que voulez-vous qu'il fit ?
; G.C. : MAKFREE MKSTRG
; MAKFREE: fabrique une nouvelle liste-libre.
MAKFREE::
SETZB FREE,A5 ; A5 : GARBF
IFN %TRPGC,<
MOVEI FREE,700000 ; pour etre sur de faire
; un trap avec ca comme index.
; car le HIGH-SEG est tjrs inferieur.
> ; pour faire un ill ref mem.
MOVE A1,BLIST
MOVE A7,ELIST ; pour accellerer le test.
MAKFR2:
CAIL A1,(A7) ; FIN LISTES ?
JRST MAKFR3 ; ouaip.
TDNN A8,MEM(A1) ; YA LE BIT G.C. ?
AOJA A5,MAKFR1 ; NAN INCR FREED CELLS.
ANDCAM A8,MEM(A1) ; OUAIP ON L'ENLEVE
AOJA A1,MAKFR2 ; ET AU SUIVANT.
MAKFR1:
MOVEM FREE,MEM(A1) ; FABRIQUE FREE.
MOVEI FREE,(A1)
AOJA A1,MAKFR2 ; AU SUIVANT.
MAKFR3:
MOVEM A5,GARBF ; sauve freed cells.
; cre une nouvelle liste libre des chaines.
MKSTRG:
SETZB STRG,A6 ; init STRG. A6 : GC.FST
MOVEI A5,1 ; A5 : GC.MST (la "" est tjrs marquee).
MOVE A1,BSTRG
SETZM MEM(A1) ; reinitialise la chaine vide "".
MKSTR1:
ADDI A1,1 ; chaine suivante.
CAML A1,BLIST
JRST MKSTR3 ; ouaip.
MOVE A2,MEM(A1) ; recupere le pointeur.
TXZN A2,BITGC ; il est marque ?
JRST MKSTR2 ; nan.
;;; la chaine etait marquee.
MOVEM A2,MEM(A1) ; on la remet sans marque.
AOJA A5,MKSTR1 ; increm nb marquees.
MKSTR2: ;;; elle etait pas marquee.
MOVEM STRG,MEM(A1) ; construit donc STRG.
MOVEI STRG,(A1)
AOJA A6,MKSTR1 ; incr nb liberees.
MKSTR3:
MOVEM A6,GC.FST ; sauve le nb de strgs liberees
MOVEM A5,GC.MST ; sauve le nb de strgs marquees.
; MKNUMB doit suivre ...
- ; G.C. : MKNUMB MKLITA
; cre une nouvelle liste libre des nombres crees.
MKNUMB:
SETZB A5,A6 ; GC.MNB, GC.FNB
SETZ NUMB,
MOVE A7,BSTRG ; pour accellerer le test.
SKIPA A1,BCNUM
MKNUM1:
ADDI A1,2 ; nb suivant.
CAIL A1,(A7) ; fin de la zone nombre ?
JRST MKNUM3 ; ouaip.
TDNN A8,MEM+1(A1) ; il est marque ?
JRST MKNUM2
;;; il etait marque.
ANDCAM A8,MEM+1(A1) ; on enleve la marque.
AOJA A5,MKNUM1 ; increm nb marques.
MKNUM2: ;;; il etait pas marque.
MOVEM NUMB,MEM(A1) ; cre donc la liste dans NUMB.
MOVEI NUMB,(A1)
AOJA A6,MKNUM1 ; increm nb liberes.
MKNUM3:
MOVEM A5,GC.MNB ; sauve le nb de nombres marques.
MOVEM A6,GC.FNB ; sauve le nb de nombres liberes.
; cre une nouvelle liste libre des atomes litteraux.
; l'ordre de l'OBLIST n'est pas change
MKLITA:
MOVEI A5,1 ; A5 : GC.MAT
SETZB A6,A7 ; GC.FAT LINK.
MOVSI A2,UNDEF ; pour le test C-val,,P-liste
MOVE A1,CATOM
MOVE A3,FATOM ; FATOM.
MKLAT3:
TDNN A8,MEM+1(A1) ; il est marque ?
JRST MKLAT6 ; nan on va y voir de plus pres.
;;; il etait marque.
ANDCAM A8,MEM+1(A1) ; on enleve la marque.
AOJA A5,MKLAT8 ; incr nb marques.
MKLAT6: ;;; il etait pas marque.
CAME A2,MEM(A1) ; C-val = UNDEF et P-liste = NIL ?
AOJA A5,MKLAT8 ; nan il faut le garder.
SKIPE MEM+5(A1) ; pas d'indic spec ni d'@ spec ?
AOJA A5,MKLAT8 ; si yen a il faut le garder.
CAMGE A1,SATOM ; preservation de tous les
AOJA A5,MKLAT8 ; atomes systemes.
;;; detruit l'atome.
JUMPE A7,MKLAT8 ; c'est le 1er.
HRRE A4,MEM+4(A1) ; recup son LINK.
HRRM A4,MEM+4(A7) ; ON shunte.
HRRM A3,MEM+4(A1) ; force FATOM dans la LINK.
MOVEI A3,(A1) ; actualise FATOM.
MOVE A1,A4 ; repositionne le pointeur courant.
AOJA A6,MKLAT9 ; incr nb liberes.
MKLAT8: ;;; au suivant de ces messieurs.
MOVEI A7,(A1) ; sauve LINK
HRRE A1,MEM+4(A1) ; litatom suivant.
MKLAT9:
JUMPGE A1,MKLAT3 ; c'est pas la fin.
MOVEM A3,FATOM ; sauve le nouveau FATOM.
MOVEM A5,GC.MAT ; sauve le nombre d'litatom marques.
MOVEM A6,GC.FAT ; sauve le nombre d'litatom liberes.
POPJ P, ; le demarquage est fini OUF...
SUBTTL I/O
$$IODL::
PRINTX /4-I.O.D.L.C./
;?!? ----- y faudrait voir a gerer les rings-buffers a la main ...
;
; CHANNEL NUMBER
;
CHIN==1 ; CHANNEL INPUT
CHOUT==2 ; CHANNEL OUTPUT
CHDRT==3 ; CHANNEL DIRECTORY
CHLIB==4 ; CHANNEL LIBRARY
CHCOR==5 ; CHANNEL CORE.
NINBUF==3 ; nb de input buffers
NOUBUF==3 ; nb de output buffers
; GESTION DE L'OCCUPATION MEMOIRE DES BUFFERS TOUT CA
; A CAUSE DU SYSTEME -DEBILE- DE DEC.
;
; SVCOR: SAUVE LES POINTEURS DE MEMOIRE ET
; LE TYPE DU DEMANDEUR.
; APEL : MOVEI A5, NO DU CANAL
; PUSHJ P,SVCOR
; RVCOR: ESSAIE DE RECUPERER LA PLACE
; MEME APPEL QUE SVCOR.
SVCOR:
MOVEM A5,SVCORT ; SAUVE NO CHANNEL.
MOVE A5,.JBREL
HRL A5,.JBFF ; FIRST FREE
MOVEM A5,SVCORA
POPJ P,
RVCOR:
CAME A5,SVCORT
POPJ P, ; VOILA C'EST PAS LE BON TYPE !!!!!
MOVE A5,SVCORA
HLRZM A5,.JBFF ; REPOSITIONNE FIRST FREE.
TLZ A5,-1
CAME A5,.JBREL
CORE A5, ; J'EN RECUPERE.
JFCL
POPJ P,
; I.O. : CONVCS CVSAT
; CONVCS : CONVERSION ASCII -> SIXBIT
; ATOME DANS A1, RESULTAT -> A5.
; APPEL: JSP L,CONVCS
CONVCS:
MOVE A5,[POINT 7,MEM+1(A1),6]
MOVE A6,[POINT 6,PNAME]
SETZM PNAME
JRST CONVS2
CONVS1:
ADDI A7,40
IDPB A7,A6
CONVS2:
ILDB A7,A5
JUMPN A7,CONVS1
MOVE A5,PNAME
JRST (L)
; CVSAT CONVERSION SIXBIT -> ATOM
; A5 -> A1
;
; APPEL : PUSHJ P,CVSAT
CVSAT:
MOVEM A5,CVSATM ; SAUVE LE SIXBIT.
JSP L,RZPNAME
MOVE A7,[POINT 6,CVSATM]
MOVNI A1,6 ; INIT POUR 6 CARACTERES.
CVSAT1:
ILDB A8,A7 ; RECUP LE SIXBIT.
JUMPE A8,CVSAT2 ; C'EST UN NULL SIXBIT.
ADDI A8,40 ; CONVERSION.
IDPB A8,A6 ; STOCK EN 7 BITS.
ADDI A5,1 ; INCR NB DE CARACTERES.
CVSAT2:
AOJL A1,CVSAT1 ; CA CONTINUE POUR LES 6 CARACTERES.
DPB A5,[POINT 7,PNAME,6] ; STORE LE NB DE CARACTERES.
JRST TRYATOM ; VERS CONVERSION ATOME.
; I.O. : CVATR
; CVATR : conversion atom -> RAD50
; A1 A5
; RAD50 : 00=null 01-12 chiffre 13-44 lettre 45 . 46 $ 47 %
; appel : JSP L,CVATR
CVATR:
MOVE A7,[POINT 7,MEM+1(A1),6] ; point sur Pname.
CVATR0:
MOVEI A8,6 ; seuls les 6 1ers cararct sont ok.
SETZ A5, ; accu = 0.
CVATR1:
ILDB A6,A7 ; car suiv en ASCII.
JUMPE A6,(L) ; yen a pu : on rentre tout de suite.
IMULI A5,50 ; Horner avec (50)8.
CAIN A6,"%"
JRST [MOVEI A6,47
JRST CVATR7]
CAIN A6,"$"
JRST [MOVEI A6,46
JRST CVATR7]
CAIN A6,"."
JRST [MOVEI A6,45
JRST CVATR7]
CAIL A6,101 ; test letres.
JRST [SUBI A6,101-13
JRST CVATR7]
CAIL A6,60 ; test chiffres.
JRST [SUBI A6,57
JRST CVATR7]
SETZ A6, ; mauvais code.
CVATR7: ; A6 est pret.
ADD A5,A6
SOJG A8,CVATR1
JRST (L)
; I.O. : CVPPN
; CVPPN : convertit PPN externe -> PPN interne.
; A1 -> A5
;
; si A1 = NIL A5 = 0 (USER PPN)
; A1 = ATOM A5 = DEVPPN(SIXBIT/ATOM/)
; A1 = (PJ . PG) A5 = conversion.
CVPPN:
SETZ A5,
JPNIL A1,VPOPJ ; PPN = NIL.
JNATOM A1,CVPPNF
JSP L,CONVCS
CAMN A5,['SYS '] ; [SAILPATCH] Sep 11 78
SKIPA A5,[' 1 3'] ; [SAILPATCH] Sep 11 78
SETZ A5, ; DEVPPN n'a pas marche.
POPJ P, ; dans tous les cas je rentre.
CVPPNF: ;;; PPN entier de type (Pj Pg).
JNLIST A1,VPOPJ ; la ya n'importe quoi.
UNCONS A1,A1,A2
PUSH P,A2 ; SAUVE LE PG.
PUSHJ P,CVPPNS
EXCH A6,(P)
MOVEI A1,(A6)
PUSHJ P,CVPPNS
POP P,A5
HRL A5,A6 ; FORME LE PG.PJ.
MOVS A5,A5 ; PUIS PJ.PG.
POPJ P, ; VOILA.
; PPN IRCAM style SIXBIT rigth justified or number.
; atom -> A1 result -> A6
CVPPNS:
SETZ A6,
JPNIL A1,VPOPJ
MOVE A6,MEM(A1) ; recup deja la valeur numerique.
JNNUMB A1,CVPPNI ; c'est pas un nb.
POPJ P, ; on ramene sa valeur.
; [SAILPATCH] Sep 11 78.
CVPPNI: ; je suis pas a l'IRCAM.
JSP L,CONVCS ; CONVERT IN SIXBIT
HLRZ A6,A5 ; RIGHT JUSTIFICATION.
TRNN A6,77
LSH A6,-6
TRNN A6,77
LSH A6,-6
TRZ A6,400000 ; pour le moniteur.
POPJ P,
; I.O. : GETSPC
; GETSPC : MET DANS GTF$DV, GTF$FL, GTF$EX , GTF$PR
; LES SPECIFICATIONS EN SIXBIT DU FICHIER A1
; AU RETOUR LR (PJ.PG) EST DANS A1.
; A1 == (DEV (FILE . EXT) (PJ . PG) PROT )
; A1 == ATOME == ('DSK' (ATOME . EXT STD) MYPPN 0)
GETSPC:
JNLIST A1,GETSP1
UNCONS A1,A1,A3 ; A1 <- DEV.
SNNIL A1
TDZA A5,A5
JSP L,CONVCS
MOVEM A5,GTF$DV
UNCONS A3,A2,A3 ; A2 <- (FILE . EXT)
GETCAR A2,A1
SNNIL A1
TDZA A5,A5
JSP L,CONVCS
MOVEM A5,GTF$FL
GETCDR A2,A1 ; A1 <- EXT
SNNIL A1
TDZA A5,A5
JSP L,CONVCS
MOVEM A5,GTF$EX
UNCONS A3,A1,A3 ; A1 <- (PJ . PG)
GETCAR A3,A5 ; A5 <- PROT
SKNUMB A5
TDZA A5,A5 ; si c'est pas un nb, = 0.
HRLZ A5,MEM(A5) ; recup la val de la prot.
LSH A5,↑D9 ; positionne en pos 0.
MOVEM A5,GTF$PR ; on la sauve.
POPJ P,
GETSP1: ; FILESPEC EST ATOMIQUE.
JNNIL A1,GETSP2
SETZM GTF$DV ; A1 = NIL
SETZM GTF$FL
JRST GETSP3
GETSP2:
JSP L,CONVCS
MOVEM A5,GTF$FL
MOVSI A5,'DSK'
MOVEM A5,GTF$DV
GETSP3:
SETZB A1,GTF$EX
SETZM GTF$PR
POPJ P,
; I.O. : INPUT
; (INPUT (DEVICE (FILENAME .EXT) (PJ . PG) ) ) [1SUBR]
INPUT:
CLOSE CHIN,
RELEAS CHIN,
JRST INPUT1
ININI: ;;; INPUT initial.
MOVE A5,FL.INI ; recup le device (e.g. DSK).
MOVEM A5,INB+1
DMOVE A5,FL.INI+1 ; recup filename.ext.
DMOVEM A5,INF ; range dans le block de controle.
SETZ A5, ; PJ.PG DE L'UTILISATUER.
JRST INPUT3
INSTD: ;;; INPUT STANDARD (TTY) .
SETZ A1,
INPUT1:
PUSHJ P,GETSPC ; CHARGE LES SPECIFS DU FICHIER.
SKIPN A5,GTF$DV
MOVE A5,FL.INP ; device standard.
MOVEM A5,INB+1 ; CHARGE LE DEVICE.
SKIPN A5,GTF$FL
MOVE A5,FL.INP+1 ; filename standard.
MOVEM A5,INF ; CHARGE LE FILENAME.
SKIPN A5,GTF$EX
MOVE A5,FL.INP+2 ; extension standard.
MOVEM A5,INF+1 ; CHARGE L'EXTENSION.
PUSHJ P,CVPPN ; conversion du PPN (qui est tjrs ds a1).
INPUT3:
MOVEM A5,INF+3 ; CHARGE LE PJ.PG .
MOVEI A5,GETCH ; PREP @ ROUTINE NEXT CHARACT.
MOVEM A5,INCHAR
MOVEI A5,CHIN ; POUR LE RECUPERATEUR
PUSHJ P,RVCOR ; DE MEMOIRE.
OPEN CHIN,INB
JRST INER1
LOOKUP CHIN,INF
JRST INER2
IFN %IRCAM,<
CALLI CHIN,-17 ; SHOWIT UUO.
JFCL
>
MOVEI A5,CHIN ; SAUVE CORE.
PUSHJ P,SVCOR
INBUF CHIN,NINBUF ; 3 BUFFERS EN ENTREE.
MOVE A5,INB+1 ; DEVICE CHARACTERISTICS.
DEVCHR A5,
PUSHJ P,CRANUM ; RAMENE LE DEVCHR.
CLRBIT IBIT11 ; C'EST PAS UNE TTY.
TXNN A5,DV.TTY ; C'EST UNE TTY ?
JRST INPUT4 ; NAN.
SETBIT IBIT11 ; C'EN EST UNE.
OUTSTR [BYTE (7)15,12," "," ","-"
ASCII /-- ALLO ? ---/
BYTE (7)15,12]
POPJ P, ; ramene le DEVCHR.
INPUT4:
SETZM CONSER ; a tout hasard.
PUSH P,A1 ; sauve le DEVCHR.
PUSHJ P,GETCH ; recup le 1er caractere du fichier.
CAIN A7,"C" ; directory de 'ETV' ?
MOVEI A7,";" ; ouaip : on force un commentaire.
MOVEM A7,CONSER ; pour le reingurgiter !
PJRST A1.P ; ramene le DEVCHR.
INER1:
PUSHJ P,OUTBUF
MOVE A6,[POINT 7,[BYTE (7)33,15,12," "," "
ASCIZ /** OPEN ERROR (INPUT)./],6]
PUSHJ P,PRBPN
PUSHJ P,OUTBUF
JRST INSTD
INER2:
PUSHJ P,OUTBUF
HRRZ A5,INF+1
PUSHJ P,CRANUM ; CONVERT NO ERREUR.
MOVE A6,[POINT 7,[BYTE (7)35,15,12," "," "
ASCIZ /** LOOKUP ERROR (INPUT) :/],6]
PUSHJ P,PRBPN
PUSHJ P,PRINT
JRST INSTD
; I.O. : OUTPUT
; (OUTPUT (DEVICE (FILENAME . EXT) (PROJ . PROG) PROT) [1SUBR]
OUTPUT:
PUSHJ P,OUTBUF ; VIDE LE DERNIER BUFFER.
CLOSE CHOUT,
RELEAS CHOUT,
JRST OUTPU1
OUTSTD:
SETZ A1, ; () .
OUTPU1:
PUSHJ P,GETSPC ; CHARGE LES SPECIFS DU FICHIER.
SKIPN A5,GTF$DV
MOVE A5,FL.OUT ; device standard.
MOVEM A5,OUTB+1 ; CHARGE LE DEVICE.
SKIPN A5,GTF$FL
MOVE A5,FL.OUT+1 ; filename standard.
MOVEM A5,OUTF ; CHARGE LE FILENAME.
SKIPN A5,GTF$EX
MOVE A5,FL.OUT+2 ; extension standard.
MOVEM A5,OUTF+1 ; ON LA CHARGE.
MOVE A5,GTF$PR ; charge la protection
MOVEM A5,OUTF+2
PUSHJ P,CVPPN
MOVEM A5,OUTF+3 ; STORE PPN.
MOVEI A5,CHOUT ; ESSAIE DE RECUPERER
PUSHJ P,RVCOR ; LA MEMOIRE.
OPEN CHOUT,OUTB
JRST OUTER1
ENTER CHOUT,OUTF
JRST OUTER2
MOVEI A5,CHOUT ; prepare la recuperation de l'espace.
PUSHJ P,SVCOR
OUTBUF CHOUT,NOUBUF ; e.g. 3 buffers en sortie.
MOVE A5,OUTB+1 ; recup le DEVICE.
DEVCHR A5, ; ramene ses caracteristiques.
CLRBIT IBIT20 ; si c'est pas une TTY, on bloque les sorties.
TXNE A5,DV.TTY ; test si TTY ?
SETBIT IBIT20 ; si oui pour ne ps bloquer les sorties.
PJRST CRANUM ; ca ramnene le DEVCHR interne.
OUTER1:
OUTSTR [BYTE (7)15,12,"?"," "," "
ASCIZ /OPEN ERROR : (OUTPUT)/]
JRST OUTSTD
OUTER2:
OUTSTR [BYTE (7)15,12,"?"," "," "
ASCIZ /ENTER ERROR : (OUTPUT)/]
RELEAS CHOUT,
JRST OUTSTD
; I.O. : FILOP
; (FILOP [channel function ...] <filespec1> <filespec2>) [3SUBR]
; appel de l'UUO FILOP.
FILOP:
JNLIST A1,FILOP2 ; ya pas de 1er arg.
UNCONS A1,A4,A1 ; A4 <- channel.
MOVE A5,MEM(A4) ; val du no de canal.
HRLM A5,FILOPB ; force le no du canal.
JNLIST A1,FILOP2 ; ya pu rien.
UNCONS A1,A4,A1 ; A4 <- fonction
MOVE A5,MEM(A4) ; val du no de la fonction.
HRRM A5,FILOPB ; force le no de la fonction.
JNLIST A1,FILOP2 ; ya pu rien.
UNCONS A1,A4,A1 ; A4 <- IOmode ou #USETI/O.
MOVE A5,MEM(A4) ; val de ce # .
MOVEM A5,FILOPB+1 ; force IOmode ou #USETI/O.
FILOP2: ; traitement 2eme arg.
PUSH P,A3 ; sauve <filespec2>.
MOVEI A1,(A2) ; A1 <- <filespec1> pour GETSPC.
PUSHJ P,GETSPC ; recup les specifs du fichier.
SKIPN A5,GTF$DV ; le device fourni ou
MOVSI A5,'DSK' ; le device std 'DSK'.
MOVEM A5,FILOPB+2 ; force in device-name ou #UDX.
; charge le ENTER/LOOKUP block.
MOVE A5,GTF$FL ; le filename
MOVEM A5,FILOPF
MOVE A5,GTF$EX ; l'extension
MOVEM A5,FILOPF+1
MOVE A5,GTF$PR ; la protection
MOVEM A5,FILOPF+2
PUSHJ P,CVPPN ; convertit le PPN dans A1.
MOVEM A5,FILOPF+3
; traitement de <filespec2>.
POP P,A1 ; recup le <filespec2>.
PUSHJ P,GETSPC ; calcul les specifs de fichier.
MOVE A5,GTF$FL ; le filename
MOVEM A5,FILOPR
MOVE A5,GTF$EX ; l'extension
MOVEM A5,FILOPR+1
MOVE A5,GTF$PR ; la protection
MOVEM A5,FILOPR+2
SETZM FILOPR+3 ; le ppn du rename block tjrs = 0.
MOVE A5,[XWD 6,FILOPB]
CALLI A5,155 ; le FILOP UUO.
PJRST CRANUM ; ramene le code erreur.
PJRST FALSE ; si OK ramene NIL.
; I.O. : DIRECTORY
; (DIRECTORY (PJ.PG) [ (FILN.EXT) ] ) [2SUBR]
; Ramene la liste de tous les fichiers presents dans un repertoire
; specifie, de + traite les "wilds cards"" simples.
DIRECT:
MOVE A5,[' 1 1'] ; [SAILPATCH] Sep 12 78. get mfd ppn.
MOVEM A5,MFDPPN
PUSH P,A2 ; SAUVE LE TEST A EFFECTUER.
PUSHJ P,CVPPN ; CONVERTIT LE PJ.PG
SKIPN A5
MOVE A5,MYPPN ; LE STANDARD.
MOVEM A5,DIRF ; STORE PPN.
OPEN CHDRT,DIRB
JRST DIRER1
LOOKUP CHDRT,DIRF
JRST DIRER2
MOVEI A5,CHDRT ; SAVE CORE.
PUSHJ P,SVCOR
INBUF CHDRT,2 ; 2 BUFFERS.
POP P,A1 ; RECUP LE TEST.
UNCONS A1,A1,A2
PUSH P,A2
SETZ A5, ; SI FIL A TESTER = NIL.
SKNIL A1
JSP L,CONVCS
MOVEM A5,DIRFIL ; STORE LE FILE A TESTER.
POP P,A1
SETZ A5, ; SI EXT A TESTER = NIL.
SKNIL A1
JSP L,CONVCS
MOVEM A5,DIREXT ; STORE L'EXT A TESTER.
CONSL A3,NIL,NIL
PUSH P,A3
PUSH P,[PD.P] ; PREPARE RETOUR DIRECT.
DIRNXT:
IN CHDRT,
JRST DIRSUV
STATZ CHDRT,74B23 ; E.O.F. ?
HALT REENTE ; YA VRAIMENT UN SAC.
CLOSE CHDRT,
RELEASE CHDRT,
MOVEI A5,CHDRT ; ESSAIE DE RECUPERER LA PLACE.
PJRST RVCOR
DIRSNV:
ILDB A5,DBLK+1 ; AVANCE DANS LE DIRECTOIRE.
SOS DBLK+2
DIRSUV:
SOSGE DBLK+2
JRST DIRNXT ; BLOCK SUIVANT.
ILDB A5,DBLK+1 ; FILNAME SUIVANT.
JUMPE A5,DIRSNV ; NULL FILENAME.
SKIPE DIRFIL ; PAS DE TEST.
JRST [CAME A5,DIRFIL
JRST DIRSNV ; LE TEST NE MARCHE PAS.
JRST .+1]
PUSHJ P,CVSAT
PUSH P,A1
SOS DBLK+2
ILDB A5,DBLK+1
HLRI A5,0
SKIPE DIREXT ; PAS DE TEST.
JRST [CAMN A5,DIREXT
JRST .+1
POP P,A1 ; LE FILN EMPILE
JRST DIRSUV]
SETZ A1, ; EN CAS DE NULL EXTENSION.
SKIPE A5
PUSHJ P,CVSAT
POP P,A2
CONSL A1,A2,
CONSL A1,A1,NIL
ADLIST A3,A1
JRST DIRSUV
DIRER1:
PUSH P,[POINT 7,[BYTE (7)↑D30,15,12," "," "
ASCIZ /** OPEN error (DIRECTORY)./],6]
JRST ERRP
DIRER2:
PUSH P,[POINT 7,[BYTE (7)↑D33,15,12," "," "
ASCIZ /** ENTER error (DIRECTORY) : /],6]
RELEASE CHDRT,
HRRZ A5,DIRF+1
PUSHJ P,CRANUM ; creation du no d'erreur.
JRST ERRPA1
; I.O. : LIBRARY
; (LIBRARY filename) [FSUBR]
; Lit en silence le fichier disque de nom specifie,
; dans les differents repertoires stockes dans LIB$PA.
; si l'extension est
; - VLI (WHILE T (EVAL (READ)))
; - VLA VLO (WHILE T (LAP1 (READ)))
LIBRARY:
GETCAR A1,A1 ; A1 <- le nom du fichier.
TXOE RG,IBIT31 ; On est deja dans la fnt LIBRARY ?
PJRST LIBPER ; Alors ca va pas (1 seul niveau possible).
JSP L,CONVCS ; Conversion du filename.
MOVEM A5,LIBF ; Sauve dans le file-block.
OPEN CHLIB,LIBB ; Tente le OPEN.
PJRST FALSE ; OPEN est faux sur /DSK/ !!
SETZ A8, ; Raz l'index dans la table des PPNs.
PUSH P,A1 ; sauve le filename (val de retour).
LIBPA:
MOVE A5,LIB$PA(A8) ; recup le ppn suivant.
JUMPL A5,P.FALS ; yen a pu ramene NIL.
MOVEM A5,LIBF+3 ; charge le ppn dans le lookupblock.
MOVSI A5,'VLI'
MOVEM A5,LIBF+1 ; charge la 1ere extension.
LOOKUP CHLIB,LIBF ; tente le 1er lookup.
JRST LIBPA2 ; c'est pas ca.
PUSH P,[LIBR1] ; prep la routine interpretative.
JRST LIBPA8 ; on y va.
LIBPA2:
MOVSI A5,'VLA'
MOVEM A5,LIBF+1 ; essaie avec VLA.
LOOKUP CHLIB,LIBF ; tente le 2eme lookup.
SKIPA A5,[SIXBIT /VLO/] ; ca va pas ENCORE.
JRST LIBPA7
LIBPA4:
MOVEM A5,LIBF+1 ; charge l'extension VLO.
LOOKUP CHLIB,LIBF ; tente le 3eme lookup.
AOJA A8,LIBPA ; ca va toujours pas : ppn suivant.
LIBPA7:
PUSH P,[LIBR2] ; prep la routine LAP.
LIBPA8:
IFN %IRCAM,<
CALLI CHLIB,-17 ; SHOWIT UUO sur le canal LIBRARY.
JFCL ; (toujours).
>
MOVEI A5,CHLIB ; PREP RECUP BUFFER.
PUSHJ P,SVCOR
INBUF CHLIB,4
MOVE A5,INCHAR ; sauve l'ancienne routine
EXCH A5,(P) ; (pour mettre LIBR1/LIBR2 en place)
MOVEM P,LIB$P ; ET LE POINTEUR DE PILE COURANT.
PUSH P,A5
MOVEI A5,LIBNCH ; Charge la nouvelle adresse
MOVEM A5,INCHAR ; de la routine qui ramene le car suivant.
SETZM CONSER ; pour etre sur de ce qui suit ...
;;; pour la compatibilite avec
;;; l'editeur 'ETV' [IRCAM]
PUSHJ P,LIBNC1 ; 1er caractere du fichier.
CAIN A7,"C" ; directory ETV ?
MOVEI A7,";" ; ouaip : on force un COMMENT.
MOVEM A7,CONSER ; pour le reingurgiter.
POPJ P, ; on tombe sur LIBR1 ou LIBR2.
LIBR1: ;;; mode interprete.
PUSHJ P,READU
PUSHJ P,EVAL ; (WHILE T (EVAL (READ)))
JRST LIBR1
LIBR2: ;;; mode LAP.
PUSHJ P,READU
CONSL A4,A1,NIL
MOVEI A2,A.LAP1 ; (WHILE T
PUSHJ P,APPLY ; (APPLY 'LAP1 (READ)))
JRST LIBR2
; I.O. : PATHLIBRARY
LIBNXT: ; ENREGISTREMENT SUIV DE LIBRARY.
IN CHLIB,
JRST LIBNCH ; C'EST TOUT BON.
STATZ CHLIB,74B23 ; E.O.F. ?
HALT REENTE ; HELL !!
CLOSE CHLIB,
RELEAS CHLIB,
IFN %IRCAM,<
CALLI CHIN,-17 ; on reaffiche INPUT.
JFCL
>
JNBIT IBIT32,LIBNX1 ; J'etait plus dans le READ.
MOVE A6,[POINT 7,[BYTE (7)↑D35,15,12," "," "
ASCIZ /** E.O.F. during READ (in LIBRARY)./],6]
LIBNX0: ;;; retour en cas d'erreur lecture.
PUSHJ P,PRBPN ; on eidte.
PUSHJ P,OUTBUF ; on le sort.
LIBNX1:
MOVEI A5,CHLIB ; ESSAIE DE RECUPERER LA PLACE DES BUFF.
PUSHJ P,RVCOR
MOVE P,LIB$P ; RECUP OLD P.
POP P,INCHAR ; RESTAURE L'ANCIENNE ROUTINE.
POP P,A1 ; RECUP FILENAME.
CLRBIT IBIT31 ; ON EST PU DANS LIBRARY.
POPJ P, ; C'EST TOUT BON.
LIBNCH: ; CARACTERE SUIVANT.
SKIPE A7,CONSER ; YAVAIT QCCH ?
JRST [SETZM CONSER ; YEN A PU !
POPJ P,]
LIBNC1:
SOSGE LBLK+2 ; IL EN RESTE DANS LE BUFFER ?
JRST LIBNXT ; NAN Y FO UN NOUVEAU BUFFER.
ILDB A7,LBLK+1 ; RECUP LE CARACTERE.
POPJ P, ; VOILA.
; (PATHLIBRARY ppn1 ppn2 ... ppnN) [FSUBR]
PATHLIBRARY:
MOVSI A8,1-LIB$PM ; PREP AOBJ POINT.
MOVEI A2,(A1)
PATHL1:
JNLIST A2,PATHL2 ; FIN DES PPN.
UNCONS A2,A1,A2 ; PPN SUIV.
PUSHJ P,CVPPN
MOVEM A5,LIB$PA(A8) ; ON LE STOCKE CONVERTIT.
AOBJN A8,PATHL1
PATHL2:
SETOM LIB$PA(A8) ; FORCE FIN TABLE.
POPJ P,
; I.O. : RDCORE WRCORE
;?!? ----- y fo faire avec les io dump .....
; DUMP image memoire impure : RDCORE WRCORE
OPCORE: ;*** OPEN FILE CORE
PUSHJ P,GETSPC ; RECUP SPECIFS DU FICHIER.
SKIPN A5,GTF$DV
MOVSI A5,'DSK' ; DEVICE STANDARD.
MOVEM A5,CORB+1 ; CAHRGE DEVICE.
SKIPN A5,GTF$FL
MOVE A5,[SIXBIT /TEMPOR/]
MOVEM A5,CORF ; CHARGE FILEN
SKIPN A5,GTF$EX
MOVSI A5,'COR' ; EXTENSION STANDARD.
MOVEM A5,CORF+1 ; CHARGE EXTENS
OPEN CHCOR,CORB
JRST OPCORR
MOVEI A5,CHCOR ; POUR RECUPERER LA PLACE.
PJRST SVCOR
CLCORE: ;*** CLOSE FILE CORE.
CLOSE CHCOR,
RELEAS CHCOR,
MOVEI A5,CHCOR ; ESSAIE DE RECUPERER LA PLACE.
PUSHJ P,RVCOR
JRST REENT
OPCORR: ;*** OPEN ERROR.
PUSHJ P,OUTBUF
PUSH P,[POINT 7,[BYTE (7)33,15,12," "," "
ASCIZ /** OPEN ERROR (CORE)./],6]
JRST ERRP
; (RDCORE filespec) [1SUBR]
RDCORE:
PUSHJ P,OPCORE ; OUVRE LE FICHIER CORE.
LOOKUP CHCOR,CORF
JRST RDCORR ; CA VA PAS.
INBUF CHCOR,4 ; 4 BUFFERS EN ENTREE.
MOVEI A6,BIMPUR ; DEBUT ZONE DUMP.
RDCOR1:
SOSGE CBLK+2 ; IL E RESTE DANS LE BUFFER ?
JRST RDCOR2 ; NON : ON RELIT.
ILDB A7,CBLK+1 ; OUI : ON RECUPE LE MOT
MOVEM A7,(A6) ; ET ON LE CHARGE EN MEMOIRE.
AOJA A6,RDCOR1 ; CA ROULE.
RDCOR2:
IN CHCOR, ; BUFFER SUIVANT.
JRST RDCOR1 ; TOUT VA BIEN.
STATZ CHCOR,74B23 ; E.O.F. ?
HALT REENT ; NAN !
JRST CLCORE
RDCORR:
PUSH P,[POINT 7,[BYTE (7)34,15,12," "," "
ASCIZ /** LOOKUP ERROR (CORE) : /],6]
CORERR:
HRRZ A5,CORF+1 ; RECUP NO ERREUR,
PUSHJ P,CRANUM
JRST ERRPA1 ; erreur avec impression de A1.
; (WRCORE filespec) [1SUBR]
WRCORE:
PUSHJ P,OPCORE ; OUVRE LE FICHIER CORE.
ENTER CHCOR,CORF
JRST WRCORR ; ERREUR.
OUTBUF CHCOR,4 ; 4 BUFFERS EN SORTIE.
MOVEI A6,BIMPUR ; INIT DEBUT ZONE DUMP.
WRCOR1:
SOSGE CBLK+2 ; Y RESTE DE LA PLACE ?
JRST [OUT CHCOR, ; NAN : VIDE LE BUFFER.
JRST WRCOR1
HALT REENT]
MOVE A7,(A6) ; RECUP LE MOT EN MEMOIRE.
IDPB A7,CBLK+1 ; ON LE MET DANS LE BUFFER.
CAMG A6,MEMEND ; FIN ZONE ?
AOJA A6,WRCOR1 ; NAN : CA ROULE.
OUT CHCOR, ; VIDE LE DERNIER BUFFER.
JRST CLCORE
HALT REENTE
WRCORR:
PUSH P,[POINT 7,[BYTE (7)↑D27,15,12," "," "
ASCIZ /** ENTER ERROR (CORE) :/],6]
JRST CORERR
; I.O. : RUN ALIAS
; (RUN filspec offset) [2SUBR]
; lance le prog filespec avec l'offset
;?!? mais pourquoi ya pas le SWAP UUO !
ARUN:
PUSH P,A2 ; sauve l'offset.
PUSHJ P,GETSPC ; recup les specifs du fichier.
SKIPN A5,GTF$DV
MOVSI A5,'SYS' ; device standard
MOVEM A5,RUNBLK ; charge le device.
MOVE A5,GTF$FL
MOVEM A5,RUNBLK+1 ; charge le filename
MOVE A5,GTF$EX
MOVEM A5,RUNBLK+2 ; charge l'extension.
PUSHJ P,CVPPN ; conversion du ppn
MOVEM A5,RUNBLK+4 ; que l'on charge.
POP P,A2 ; recupere l'offset.
HRLZ A5,MEM(A2) ; A5 <- val de l'offset
HRRI A5,RUNBLK ; prepare le parametre
RUN A5, ; C'est parti.
JRST FALSE ; ca va pas.
JRST REENT ; normallement c'est un aller simple!
; (ALIAS ppn) [1SUBR]
; permet d'executer la commande moniteur ALIAS.
ALIAS:
IFN %IRCAM,< ; ca ne marche qu'a l'IRCAM.
JUMPN A1,ALIAS1 ; ya un PPN de fourni.
MOVS A5,PNJOB ; prepare le GETTAB [pjob ,, 2]
HRRI A5,2
GETTAB A5,
JFCL ; ce GETTAB marche pas ??
JRST ALIAS2 ; on a le LOGIN ppn.
ALIAS1:
PUSHJ P,CVPPN ; interne le PPN.
ALIAS2:
JUMPE A5,FALSE ; ya des tas de raisons :
; CVPPN ou GETTAB n'a pas marche.
MOVEM A5,MYPPN ; ca devient le nouveau PPN.
CHGPPN A5, ; le CALLI 47 !
JFCL ; y toujours l'error return.
> ; de %IRCAM.
MOVE A5,MYPPN
PJRST PPNVAL ; ramene le PPN courant.
; I.O. : SHOWIT TMPCOR
; (SHOWIT channel) [1SUBR]
IFN %IRCAM,< ; l'UUO existe.
SHOWIT:
MOVE A5,[CALLI 0,-17] ; charge l'UUO SHOWIT.
HRLZ A6,MEM(A1) ; recup le n0 de canal.
LSH A6,5 ; en position Ac.
IOR A5,A6 ; cre l'instruction complete.
XCT A5 ; execute l'UUO.
JFCL ; si ca marche pas.
POPJ P, ; ramene le numero de canal.
>
IFE %IRCAM,< ; l'UUO n'existe pas.
SHOWIT=FALSE >
; (TMPCOR name) [1SUBR] ramene la chaine du TMPCOR lu.
TMPCOR:
JSP L,CONVCS ; traduit le name en SIXBIT.
MOVEM A5,TMPCRA ; force le nom dans le block de controle.
MOVE A5,[XWD 1,TMPCRA] ; demande de lecture de TMPCOR.
TMPCOR A5,
PJRST CRANUM ; ERROR : ramene free words.
MOVE A5,[POINT 7,TMPCRB] ; prepare le point pour ramasser
MOVEM A5,TMPCRP ; l'ASCII du buffer.
; conversion en chaine.
CONSL A1,NIL,NIL ; prepare la liste resultat.
PUSH P,A1 ; pour la val de retour.
MOVEM A1,TEMP$L ; pour travailler.
JRST TMPCO4 ; au travail.
TMPCO2:
PUSHJ P,CRACAR ; conversion en caractere.
CONSL A1,A1,NIL ; prepare le doublet a accrocher.
MOVE A5,TEMP$L ; recup le LAST.
PUTCDR A5,A1 ; accrochage physique.
MOVEM A1,TEMP$L ; on le resauve.
TMPCO4:
ILDB A7,TMPCRP ; recup le car suiv.
JUMPN A7,TMPCO2 ; c'est pas la fin du buffer.
; et ya toujours un 0 a la fin.
PJRST PD.P ; ramene le CDR du sommet de pile.
; TTY : TYI TYS TYO PPIOT CALLI
; Fonctions travaillant sur la TTY uniquement.
; (TYI) [0SUBR] ramene le code interne du caractere tape.
TYI: INCHRW A5 ; A5 <- caractere suivant.
JRST CRANUM ; que l'on interne.
; (TYS) [0SUBR] teste si un car a ete frappe.
TYS: CALLI A5,-5 ; SNEAKS UUO.
JRST FALSE
JRST CRANUM
; (TYO N) [1SUBR] sort n sur la TTY.
TYO: OUTCHR MEM(A1) ; ecrit la val du nb.
POPJ P, ; tout est dit.
; (PPIOT no arg) [2SUBR]
; effectue l'UUO PPIOT no,arg
APPIOT:
MOVSI A5,(PPIOT)
MOVS A6,MEM(A1)
LSH A6,5 ; postion AC field.
AND A6,[740,,0] ; masque le no du reg AC.
IOR A5,A6
HRRZ A6,MEM(A2)
IOR A5,A6
XCT A5
JFCL
POPJ P,
; (CALLI n accu) [SUBR 2] appelle l'UUO CALLI normale.
; le 2eme arg est necessaire e.g. le FREEZE UUO.
ACALLI:
MOVSI A5,(CALLI A5,)
HRR A5,MEM(A1) ; force AE field.
JPNIL A2,ACALL1 ; ya pas d'accu.
HRLZ A6,MEM(A2)
LSH A6,5 ; piosition AC field.
IOR A5,A6 ; que l'on ajoute.
ACALL1:
XCT A5 ; effectue vraiment l'UUO.
JRST FALSE ; retour erreur.
JRST CRANUM ; rtour vrai.
; TTY : SETACTABLE TRMOP
; (SETACTABLE l) [1SUBR]
; si l est donne force une nouvelle table d'activation
; dans tous les cas ramene la table courante d'activation
ASETACT:
HRLZI A5,SETCTO ; prepare l'adresse de la vielle table.
JNLIST A1,SETCT2 ; ya pas d'arg.
MOVSI A6,-4 ; -taille de la table.
SETCT1:
UNCONS A1,A2,A1 ; A2 <- val suivante.
MOVE A7,MEM(A2)
MOVEM A7,SETCTN(A6) ; force la nouvelle valeur.
SNLIST A1 ; fin de la liste arg.
AOBJN A6,SETCT1 ; pour les 4 mots.
HRRI A5,SETCTN ; ya une nouvelle table.
SETCT2:
PPIOT 11,A5 ; SETACT UUO.
JFCL
SETZ A4, ; prep le result.
MOVEI A6,3 ; de nouveau un compteur.
SETCT3:
MOVE A5,SETCTO(A6) ; recup l'elem de la vielle table.
PUSHJ P,CRANUM
CONSL A4,A1,A4
SOJGE A6,SETCT3 ; yen a encore.
MOVEI A1,(A4) ; ramene la liste cree.
POPJ P,
; (TRMOP fnt index valeur) [SUBR 3]
; appel de l'UUO TRMOP.
TRMOP:
MOVE A5,MEM(A1) ; charge le 1er arg.
MOVEM A5,TRMOPB
MOVE A5,MEM(A2) ; charge le 2eme argument.
MOVEM A5,TRMOPB+1
MOVE A5,MEM(A3) ; charge le 3eme arg.
MOVEM A5,TRMOPB+2
MOVE A5,[XWD 3,TRMOPB]
TRMOP. A5,
PJRST FALSE ; retour erreur.
PJRST CRANUM ; la val est dans A5.
; TTY : UPGIOT
; (UPGIOT N L) [2SUBR] sort sur la TTY la liste
; des codes internes en utilisant les flags n
; UPGIOT permet d'utiliser les codes speciaux de
; positionnement sur une TTY DM en IRCAM MODE.
; (DISPLAY L N) [SUBR 2] idem avec args inverses.
DISPLAY:
EXCH A1,A2
UPGIO:
JPNIL A1,UPGIO1 ; ya pas de 1er arg (de flag).
MOVE A5,MEM(A1) ; recup la val des flags.
HRLM A5,UPGBLK ; force les nouveaux flags.
UPGIO1:
MOVSI A5,-UPGBFM ; raz le buffer de sortie.
UPGIO2:
SETZM UPGBUF(A5)
AOBJN A5,UPGIO2
MOVE A5,[POINT 7,UPGBUF]
JPLIST A2,UPGIO4 ; y fo vraiment editer ?
HLRZ A5,UPGBLK ; nan : recupere les flags.
JRST CRANUM ; que l'on interne.
UPGIO4:
UNCONS A2,A1,A2 ; A1 <- car suivant.
MOVE A6,MEM(A1) ; A6 <- la val du nb.
IDPB A6,A5 ; on la range.
JPLIST A2,UPGIO4 ; il en reste.
HRRZ A5,A5 ; A5 <- adr du pointeur.
SUBI A5,UPGBUF-1 ; A5 <- nb de mots charges.
MOVEM A5,UPGBLK+1 ; ce nb est range.
PPIOT 12,UPGBLK ; lancement du transfert.
JRST FALSE ; !! ya un sac !!
JRST TRUTH ; si tout va bien ramene tjrs T.
; TTY: XYDISPLAY
; (XYDISPLAY n0-ligne n0-col liste-de-codes-caracteres) [SUBR 3]
; n0-ligne de 0 a 38. n0-col de 0 a 83.
; supposement adapte aux SAIL DATADISCS.
; A1 = n0-ligne, A2 = n0-col, A3 = liste-de-codes-caracteres.
XYDISP:
MOVSI A5,-DDBFM ; coller a 1 le buffer de sortie (1: txtword).
MOVEI A6,1
XYDIS2:
MOVEM A6,DDBUF(A5)
AOBJN A5,XYDIS2
MOVE A5,[POINT 7,DDBUF]
XYDIS4:
UNCONS A3,A4,A3 ; A4 = le caractere suivant.
MOVE A6,MEM(A4) ; A6 = la valeur du nombre.
IDPB A6,A5 ; on la range.
JPLIST A3,XYDIS4 ; il en reste.
MOVEI A6,15 ; CR
IDPB A6,A5 ; force.
MOVEI A6,12 ; LF
IDPB A6,A5 ; force.
HRRZ A5,A5 ; A5 = adresse-mot du pointeur.
ADDI A5,1 ; au mot suivant.
SETZM @A5 ; 0 dedans. C est le HALT du dd-prog.
SUBI A5,DDPROG-1 ; A5 = longueur du dd-prog.
MOVEM A5,DDBLK+1 ; qu on range a l endroit idoine.
; A PRESENT: extraction des
; n0s-de-col et n0s-de-ligne.
MOVE A8,MEM(A1) ; n0-ligne dans A8.
IMULI A8,↑D12 ; 12 lignes graphiques par caractere.
MOVE A6,MEM(A2) ; n0 de colonne dans A6.
ADDI A6,2 ; on commence en colonne-2-physique a SAIL.
LSH A6,↑D8 ;
MOVE A7,A8 ; n0-ligne (I.E. n0 original * 12)
LSH A7,-4 ; attrape les high-5-bits du n0-ligne.
OR A6,A7 ;
LSH A6,↑D8 ; on decale de 8.
MOVE A7,A8 ; n0-ligne encore.
ANDI A7,↑D15 ; attrape les low-4-bits du n0-ligne.
OR A6,A7 ; tout est place, a present ...
LSH A6,↑D12 ; on decale dans les 24 1ers bits de A6.
OR A6,DDLICO ; puis on fabrique un DDLICO complet dans A6
MOVEM A6,DDPROG+1 ; qu on place opportunement.
DDUPG DDBLK ; transfert: en voiture Simone !!!
JRST FALSE ; en cas de sac.
JRST TRUTH ; si tout va bien, on ramene T.
SUBTTL FONCTIONS D'ENTREE
$$INPT::
PRINTX /5-ENTREE/
; GETNEX : passe a l'enregistrement suivant en entree.
; si c'est une TTY une indentation est faite automatiquement.
; appel : PUSHJ P,GETNEX
GETNEX:
JNBIT IBIT11,GETNX0 ; c'est pas une TTY .
;;; on est en mode TTY
OUTSTR PINTER ; edite "? "
SKIPGE A7,DPREAD ; recupere la profondeur.
JRST GETNX0 ; <= 0 ?!?
CAIL A7,8 ; on ne traite pas des profondeurs
MOVEI A7,7 ; plus grande que 7!
JRST .+2
OUTSTR PSPACE ; edite les indentations.
SOJGE A7,.-1 ; autant qui faut.
GETNX0: ;;; traitement normal.
IN CHIN, ; LECTURE BUFFER.
JRST GETNX1 ; TOUT VA BIEN.
STATZ CHIN,74B23 ; E.O.F. ?
HALT REENTE ; NON = FIN ANORMALE.
CLOSE CHIN, ; FERMETURE FILE ENTREE.
RELEAS CHIN, ; FERMETURE DEVICE ENTREE.
MOVEI A1,A.EOF
SETZ A4,
PUSHJ P,APPLY ; APPEL DE LA FN "EOF".
JRST GETNEX
GETNX1:
JNBIT IBIT10,VPOPJ ; Y FOO PAS ECRIRE LES ENREGISTREMENTS.
MOVEMM PREFOR,A5,PRPREF
DMOVE A5,IBLK+1 ; RECUP POINT COMPT.
DMOVEM A5,GETNXP
JRST .+2
GETNX2:
PUSHJ P,PRCH ; SORT LE CARACT.
SOSGE GETNXC
JRST GETNX3 ; YEN A PU.
ILDB A7,GETNXP
HRRZ A8,TABCAR(A7) ; RECUP TYPE.
JUMPN A8,GETNX2 ; TYPE # BREAK.
GETNX3:
PUSHJ P,OUTBUF
MOVEMM PREFPR,A5,PRPREF ; RESTAURE PREFIXE.
POPJ P, ; VOILA.
; IN : EOF
; La fonction EOF standard, ouvre le fichier
; d'entree standard et rentre au top-level.
EOF:
PUSHJ P,OUTBUF ; vide le dernier buffer.
TXZE RG,IBIT32 ; je suis dans un READ ?
SKIPA A6,[POINT 7,[BYTE (7)↑D23,"*","*"," "," "
ASCIZ /E.O.F. during READ./],6]
MOVE A6,[POINT 7,[BYTE (7)↑D10,"*","*"," "," "
ASCIZ /E.O.F./],6]
PUSHJ P,PRBPN ; edite l'un ou l'autre message.
PUSHJ P,OUTBUF ; vide le buffer.
PUSHJ P,INSTD ; ouvre le fichier standard d'entree.
JRST REENT ; retour au top-level.
;;; pourquoi !
; IN : GETCH GETCHV
; G E T C H : met dans A7 en ASCII :
; - le caractere suivant du flux d'entree
; - le caractere precedent (sauve dans CONSERV)
; C'est le @INCHAR standard !
; appel: PUSHJ P,@INCHAR.
GETCH1:
PUSHJ P,GETNEX ; nouveau buffer.
GETCH:
SKIPE A7,CONSER ; ya qqch a REINGURGITER ?
JRST GETCH9 ; ouaip.
SOSGE IBLK+2 ; ya encore des caracteres dans le buffer ?
JRST GETCH1 ; nan : nouveau buffer.
ILDB A7,IBLK+1 ; recup le caractere suivant.
POPJ P, ; voila !
GETCH9:
SETZM CONSER ; je l'efface
POPJ P, ; tout est dit.
; GETCHV : ramene le 1er caractere LISP valide -> A7
; si c'est une macro (@MACRO,TYPE) -> A8
; effectue egalement le trancodage min-MAJ.
GETCV1: ;;; chaine commentaire.
PUSHJ P,@INCHAR
CAME A7,COMMEN ; de nouveau le separateur.
JRST GETCV1 ; nan : c'est toujours le commentaire.
GETCHV:
PUSHJ P,@INCHAR ; car suiv.
MOVE A8,TABCAR(A7) ; charge le type du caractere.
CAME A7,QUOTEC ; c'est un QUOTE-caractere (/) ?
JRST GETCV2 ; nan : vers les autres tests.
SNBIT IBIT14 ; il faut traiter les / ?
PJRST @INCHAR ; oui : relecture et retour
; sans changer le type !
GETCV2:
CAME A7,COMMEN ; c'est le debut d'un commentaire ?
JRST GETCV3 ; nan : vers le transcodage.
SNBIT IBIT18 ; oui : il faut les traiter ?
JRST GETCV1 ; oui : on y va ...
GETCV3:
SKBIT IBIT15 ; y fo traiter les macros ?
HRRZ A8,A8 ; nan : enleve l'@ macro.
CAIL A7,"A"+40 ; conversion minuscule -> majuscules.
CAILE A7,"Z"+40 ; a min <= caractere <= z min.
POPJ P, ; nan : c'est fini.
SNBIT IBIT19 ; la traduction est valide ?
TRC A7,40 ; ouaip: je convertis.
POPJ P,
; IN : RZPNAME READ1
; RZPNAME : prepare le zone du P-name
; APPEL : JSP L,RZPNAME
RZPNAME:
MOVE A5,[PNAM0,,PNAME] ; raz les 8 mots du Pname.
BLT A5,PNAME+7
MOVE A6,[POINT 7,PNAME,6]
SETZ A5, ; souvent le nb de carct
JRST (L) ; voila
; READ1: RAMENE L'ATOME OU LE SEPATEUR LISP SUIVANT.
; A1 <- ATOME OU NOMBRE OU CHAINE.
; A8 <- TYPE 0 ATOME OU NOMBRE
; 1 . 2 ( 3 ) 4 [ 5 ]
; (@MACRO,TYPE)
READ1::
PUSHJ P,GETCHV ; CAR VALID SUIVANT.
TLNE A8,-1 ; MACRO-CARACTERE ?
JRST READM ; ET OUI.
SOJLE A8,READ1 ; SAUTE TOUS LES BREAKS, NULLS.
CAIE A8,1 ; C'EST PAS UN NORMAL.
SOJA A8,VPOPJ ; JE RENTRE (TYPE - 2).
CAME A7,CSTRIN ; DELIMITEUR DE CHAINE ?
JRST READ11 ; NAN : CONTINUE.
SNBIT IBIT17 ; Y FO TRAITER LES CHAINES ?
JRST REASTR ; MAIS OUI.
READ11:
JSP L,RZPNAME ; raz zone P-name.
MOVNI A5,MAXCPP ; chien de garde du buffer P-name.
READ12:
AOJG A5,READ13 ; ya plus de 39 caractrere !!!
IDPB A7,A6 ; ON LE STOCKE DANS PNAME.
READ13:
PUSHJ P,GETCHV ; au suivant.
CAIE A8,3 ; "." (nb flottant) ?
CAIN A8,2 ; ou normal ?
JRST READ12 ; c'est donc un caractere du P-name.
MOVEM A7,CONSER ; sinon je sauve ce special.
ADDI A5,MAXCPP ; calcul le vrai nb de caracteres.
CAILE A5,MAXCP
MOVEI A5,MAXCP ; pour pas depasser 13 caracteres.
; dans les atomes litteraux.
DPB A5,[POINT 7,PNAME,6] ; force le nb de caracteres.
PUSH P,[READM6] ; prepare le retour de TRYATOM.
; TRYAT DOIT SUIVRE .....
; IN : TRYATOM
; TRYATOM : examine la chaine dans PNAME.
; si c'est un atome litteral -> CRATOM,
; un nb entier -> CRANUM,
; un nb flottant -> CRAFLT.
; (on ne traite pas encore les nnn.nnnEnnn).
; A1 < 0 avant le ".", sinon compte des digits apres le ".".
TRYATOM::
MOVE A6,PNAME ; traite le cas du point simple.
CAMN A6,[BYTE (7)1,".",0,0,0]
JRST CRATOM ; et c'est le cas.
MOVE A6,[POINT 7,PNAME,6] ; initialise le pointeur sur PNAME.
SETZB A5,SIGNE ; ACCU = 0 ; SIGNE = POSITIF.
MOVNI A1,100 ; init nb de caracteres .
ILDB A7,A6 ; 1er caractere (peut etre le signe).
CAIE A7,"+" ; SIGNE + ?
JRST TRYAT1 ; NON : CONTINUE.
SNBIT IBIT12 ; TRAITEMENT + VALIDE ?
JRST TRYAT2 ; OUI.
TRYAT1:
CAIE A7,"-" ; SIGNE - ?
JRST TRYAT3 ; YAURA DONC PAS DE SIGNE.
SNBIT IBIT13 ; TRAITEMENT - VALIDE ?
SETOM SIGNE ; OUI.
TRYAT2:
ILDB A7,A6
JUMPE A7,CRATOM ; YA QUE LE SIGNE ...
TRYAT3:
CAIN A7,"."
JRST TRYAT6
SUBI A7,"0"
JUMPL A7,CRATOM ; C'EST PAS UN CHIFFRE.
CAIG A7,11 ; DE "0" A "9".
JRST TRYAT4
CAIGE A7,21
JRST CRATOM ; ENTRE LETTRES ET CHIFFRES.
SUBI A7,7
TRYAT4:
CAML A7,IBASE ; c'est pas un bon digit.
JRST CRATOM ; on cre donc un atome literal.
; [PAT] amelioration des conversions
; en cas de puissance de 2.
XCT IBASEX ; IBASEX contient toujours :
; soit IMUL A5,IBASE soit LSH A5,n
ADD A5,A7 ; finit de HORNER.
AOJA A1,TRYAT7 ; compte le nb de carcteres.
TRYAT6: ; y vient d'avoir un point.
JUMPGE A1,CRATOM ; yavait deja eu un . .
SETZ A1, ; RAZ le compteur de caracteres.
TRYAT7:
ILDB A7,A6 ; caractere suivant.
JUMPN A7,TRYAT3 ; c'est pas fini.
SKIPE SIGNE
MOVN A5,A5 ; le signe etait negatif.
JUMPL A1,CRANUM ; ya pas eu de . => nb entier.
IDIVI A5,400000 ; met sous format float.
SKIPE A5
TLC A5,254000
TLC A6,233000
FAD A5,A6
JUMPLE A1,CRAFLT ; rien apres le "."
FDVR A5,[10.0] ; / 10 jusqu'a mettre le "."
SOJG A1,.-1 ; a la bonne place.
JRST CRAFLT ; vers la creation flottante.
; IN : REASTR
; lecture d'une chaine dans le flux d'entree.
REASTR::
CONSL A1,NIL,NIL ;PREPARE LA LISTE RESULTAT.
PUSH P,A1
MOVEM A1,TEMP$L ; SAUVE LAST.
JRST REAST2
REAST1:
PUSHJ P,CRACAR ; CRE L'ATOME MONO CARACTERE.
CONSL A1,A1,NIL
MOVE A5,TEMP$L
PUTCDR A5,A1 ; AJOUTE A LA CHAINE.
MOVEM A1,TEMP$L
REAST2:
PUSHJ P,@INCHAR ; CARACTERE SUIVANT.
CAME A7,CSTRING ; C'EST UN " ?
JRST REAST1 ; NAN.
PUSHJ P,@INCHAR ; OUAUNE MAURE TAIMSE
CAMN A7,CSTRING ; C'EST UN DOUBLE " ?
JRST REAST1 ; OUAIP.
MOVEM A7,CONSER ; NAN : JLE SAUVE.
SETZ A8, ; TYPE = ATOME.
PJRST CRPSTR ; CREATION CHAINE EN PILE.
; IN : CRATOM
; C R A T O M : creation d'un atome alpha.
; ya pas de hash-coding mais une optimisation de la recherche
; dans l'OBLIST:
; - si l'atome existait deja on le met en tete de l'OBLIST.
; - on cre tous les atomes en tete de l'OBLIST egalement.
; c'est fou ce qu'on gagne pour le READ
; (et sans le lenteur du HASHCOD).
; La liste des atomes se termine par -1 in Rh.
CRATOM::
SETZ A8, ; pour eviter tout malentendu ...
DPB A8,[POINT 7,PNAME+2,↑D34] ; force le dernier caract. a 0.
DMOVE A5,PNAME ; recup les 3 mots du P-name,
MOVE A7,PNAME+2 ; dans A5,A6,A7.
SETZ A8, ; Raz pointeur avant.
MOVE A1,CATOM ; debut liste ds atomes.
JRST CRATO2 ; c'est parti.
CRATO1:
MOVEI A8,(A1) ; sauve Precedent.
HRRE A1,MEM+4(A1) ; atome suivant.
JUMPL A1,CRATO5 ; yen a pu.
CRATO2:
CAME A5,MEM+1(A1) ; test P-name 1.
JRST CRATO1
CAME A6,MEM+2(A1) ; test P-name 2.
JRST CRATO1
CAME A7,MEM+3(A1) ; test P-name 3.
JRST CRATO1
;;; l'atome existait.
JUMPE A8,VPOPJ ; il est deja en tete de l'OBLIST.
HRRZ A5,MEM+4(A1) ; shunt les liens.
HRRM A5,MEM+4(A8) ; de l'atome trouve.
MOVE A5,CATOM ; place l'atome en tete.
HRRM A5,MEM+4(A1)
MOVEM A1,CATOM ; actualise CATOM.
POPJ P, ; voila.
CRATO5: ;;; creation d'un nouvel atome.
MOVE A1,FATOM ; recup la liste free atoms.
DMOVEM A5,MEM+1(A1) ; store le P-name.
MOVEM A7,MEM+3(A1)
MOVSI A5,UNDEF ; store C-val,,P-liste.
MOVEM A5,MEM(A1)
HRRE A6,MEM+4(A1) ; new FATOM.
MOVE A5,CATOM ; store bits spec,,link.
MOVEM A5,MEM+4(A1)
SETZM MEM+5(A1) ; raz indic + @ speciales.
MOVEM A1,CATOM ; actualise CATOM.
MOVEM A6,FATOM ; actualise FATOM.
JUMPGE A6,VPOPJ ; il en reste pour la suite.
PUSHJ P,GARBCA
SKIPL FATOM ; J'en ai recupere ?
POPJ P, ; ouaip.
JRST ERAT ; nan (vers ERREUR ATOM).
; IN : CRACAR CRASTR CRASTN CRPSTR
; CREATION ATOME MONO-CARACTERE. IL EST DANS A7.
CRACAR::
JSP L,RZPNAM ; raz de la zone du P-name.
MOVEI A8,1 ; NB DE CARACTERES.
DPB A8,A6
IDPB A7,A6
JRST TRYATOM ; POUR LES CARACTERES NUMERIQUES.
; CRASTR : CREATION D'UNE CHAINE A1 -> A1
; CRASTN : CRE LA CHAINE VIDE -> A1
; CRPSTR : CRE LA CHAINE EN PILE
CRPSTR:
POP P,A1 ; RECUP LA LISTE DE CARACTERES EN PILE.
CRDSTR:
GETCDR A1,A1 ; ENLEVE LE 1ER DOUBLET.
CRASTR:
JPNIL A1,CRASTN ; C'EST DONC LA CHAINE VIDE.
JUMPE STRG,[PUSHJ P,GARBCL
JUMPN STRG,.+1
JRST ERATS]
EXCH A1,MEM(STRG)
EXCH STRG,A1
POPJ P,
CRASTN:
MOVE A1,BSTRG
POPJ P,
; IN : CRANUM CRAZER CRAONE CRAFLT
; C R A N U M : creation d'un nombre.
; en entree A5 <- le nombre,
; en sortie A1 <- l'adresse de cet atome.
; appel : PUSHJ P,CRANUM.
CRANUM::
JUMPL A5,[MOVN A1,A5
CAMG A1,C.NNUM
JRST CRANU0
JRST CRANU1]
CAML A5,C.PNUM
JRST CRANU1 ; c'est un grand nombre.
CRANU0: ; calcul l'adresse d'un "petit" entier.
MOVE A1,PZER
ADD A1,A5 ; pas ADDI a cose des nbs negatifs !
POPJ P,
CRANU1: ; creation nombre en zone nombre.
SETZ A6, ; fixe number.
CRANU2: ; A6 <- 0 si FIX.
; A6 <- -1 si FLOAT.
JUMPE NUMB,[PUSHJ P,GARBCL ; yen a pu.
JUMPN NUMB,CRANU3
JRST ERATN] ; vraiment pu.
CRANU3:
MOVE A1,A5 ; pas de MOVEI a cose des nbs negatifs.
EXCH A1,MEM(NUMB)
EXCH NUMB,A1
MOVEM A6,MEM+1(A1)
POPJ P,
CRAZER::
MOVE A1,PZER ; creation du 0 fixe (pour
POPJ P, ; l'interprete et le compilo).
CRAONE:: ; creation du 1 (pour le compilo).
MOVE A1,PZER
ADDI A1,1
POPJ P,
CRAFLT::
HLLOI A6, ; indicateur float.
; i.e. : 0,,777777
JRST CRANU2
; IN : $CRANB $CRANP creations nb pour le compilo
; $CRANB $CRANP cre le nb contenu dans A5 de type entier.
; appel : (JSP L :$CRANB) / (JSP L :$CRANP)
; si $CRANP, la rpresentation interne est empilee.
$CRANB::
JUMPL A5,CRNB2 ; si nb negatif.
CAML A5,C.PNUM
JRST CRNB3 ; vers l'internement.
CRNB1: ;;; c'est un 'petit' entier.
MOVE A1,PZER
ADD A1,A5
JRST (L)
CRNB2:
CAMG A1,C.NNUM
JRST CRNB1 ; pas la peine de l'interner.
CRNB3: ;;; internement du nb.
JUMPE NUMB,CRNB9 ; ya pu de dublet de nb.
CRNB4:
MOVE A1,A5 ; pour calculer direct le point.
EXCH A1,MEM(NUMB)
EXCH NUMB,A1
SETZM MEM+1(A1) ; type du nb : entier.
JRST (L) ; A1 est donc pret.
CRNB9:
PUSHJ P,GARBCN ; appel GC des nbs.
JUMPN NUMB,CRNB4
$CRANP::
JUMPL A5,CRNP2 ; si nb negatif.
CAML A5,C.PNUM
JRST CRNP3 ; vers l'internement.
CRNP1: ; pas de creation.
MOVE A1,PZER
ADD A1,A5
PUSH P,A1 ; on doit empiler a1.
JRST (L)
CRNP2:
CAMG A1,C.NNUM
JRST CRNP1 ; pas la peine de l'interner.
CRNP3: ;;; internement du nb.
JUMPE NUMB,CRNP9 ; ya pu de dublet de nb.
CRNP4:
MOVE A1,A5 ; pour calculer direct le point.
EXCH A1,MEM(NUMB)
EXCH NUMB,A1
SETZM MEM+1(A1) ; type du nb : entier.
PUSH P,A1 ; il faut empiler la valeur.
JRST (L) ; A1 est donc pret.
CRNP9:
PUSHJ P,GARBCN ; appel GC des nbs.
JUMPN NUMB,CRNP4
JRST ERATN ; ** no room for numbers.
; IN : READ READU
; READ: lit une S-expression. FONCTION INTERNE.
READL1: MEXP VPOPJ,ERLC01,REA1,ERLC02,REA11,ERLC03 ; ATOM . ( ) [ ]
READL2: MEXP REA6,REA3,REA5,REA7,REA51,REA71 ; ATOM . ( ) [ ]
READ::
PUSHJ P,READ1 ; 1er objet.
REA0:
JRST @READL1(A8) ; aiguillage sur le type.
REA1: ;;; 1ere fois "(".
TDZA A2,A2 ; A2 <- NIL.NIL
REA11: ;;; 1ere fois "[".
MOVSI A2,A.LIST ; A2 <- LIST.NIL
CONSL A2
PUSH P,A2 ; sauve LAST.
AOS DPREAD ; actualise la profondeur du READ.
REA2:
PUSHJ P,READ1 ; objet suivant.
JRST @READL2(A8) ; reaiguillage sur le type.
REA3: ;;; cas dot (.) .
SOS DPREAD ; actualise la profondeur du read.
PUSH P,A2 ; sauve last.
PUSHJ P,READ
POP P,A2
PUSHJ P,READ1 ; objet suivant,
; [PAT] AUG 28 1978
CAIN A8,3 ; est-ce une ")" ?
JRST REA33 ; oui.
CAIE A8,5 ; est-ce une "]" ?
JRST ERLC04 ; non helas.
POP P,A3 ; A3 = 1er truc lu.
GETCAR A3,A4 ; recup son car dans A4
CAIE A4,A.LIST ; est-ce LIST ?
JRST ERLC05 ; non. je tire..
GETCDR A3,A4
CAIE A4,(A2) ; le truc global est-il [x . y] ?
JRST REA31 ; non. C'est un MCONS.
MOVEI A4,A.CONS ; oui. C'est un CONS.
PUTCAR A3,A4 ; smasher le-car.
JRST REA32
REA31:
MOVEI A4,A.MCONS
PUTCAR A3,A4 ; car-1er-truc-lu <- MCONS.
REA32:
; le truc lu apres le point
CONSL A1,A1,NIL ; devient un cons bien gras.
; qui perce A2 dans ce qui suit.
PUTCDR A2,A1
MOVEI A1,(A3)
POPJ P,
REA33:
PUTCDR A2,A1
PJRST PD.P
REA51: ;;; "[" suivant.
PUSH P,A2
PUSHJ P,REA11
POP P,A2
JRST REA6
REA5: ;;; "(" suivante.
PUSH P,A2 ; sauve LAST.
PUSHJ P,REA1
POP P,A2
REA6: ; formation de la liste result.
CONSL A1,A1,NIL
ADLIST A2,A1 ; ajoute a la liste.
JRST REA2 ; ca continue.
REA71: ;;; "]" final.
SOS DPREAD ; actualise la profondeur du READ.
POP P,A1 ; recup liste resultat.
GETCAR A1,A3 ; et son CAR.
CAIE A3,A.LIST ; cree par "[" ?
JRST ERLC06 ; non. Je tue a regret.
GETCDR A1,A3 ; recup son CDR.
CAIE A3,(A2) ; truc global de la forme [x] ?
POPJ P, ; non. Retour calme.
MOVEI A3,A.NCONS
PUTCAR A1,A3 ; on smashe car A1 avec NCONS.
POPJ P, ; retour hysterique apres le smash.
REA7: ;;; ")" final.
SOS DPREAD ; actualise la profondeur du READ.
POP P,A1 ; recup liste resultat.
UNCONS A1,A2,A1
JNNIL A2,ERLC07 ; pas cree par "(" !
JNBIT IBIT16,VPOPJ ; pas de MACRO-FONCTIONS D'ENTREE.
GETCAR A1,A2 ; recup (CAR (READ))
JNATOM A2,VPOPJ ; c'est surement pas une MACRO-FN IN.
REA74: ;;; explore P-liste de (CAR (READ)))
GETCDR A2,A3
JNLIST A3,VPOPJ ; fin p-liste.
UNCONS A3,A3,A2
CAIN A3,MACIN ; test de l'indicateur.
JRST REA75
JPLIST A2,REA74
POPJ P, ; fin p-liste.
REA75: ;;; indicateur MACIN trouve.
GETCDR A1,A4 ; A4 <- (CDR (READ))
GETCAR A2,A1 ; A1 <- (GET (CAR (READ)) 'MACIN)
PJRST APPLY ; on le fait !
; READ utilisateur doit sauter toutes les ) en trop.
READU:
PUSHJ P,READ1 ; lecture de la 1ere U.S.
CAIN A8,3 ; test si ) ?
JRST READU ; et c'est le cas : on les saute.
JRST REA0 ; vers le traitement normal.
; IN : READM MQUOTE MOCTAL
; M A C R O S E N T R E E
READM: ; TRAITEMENT DES MACROS-CARACTERES.
HLRZ A7,A8 ; RECUP @ MACRO.
PUSH P,A2 ; SAUVE LAST.
MOVN A8,DPREAD ; sauve la profondeur
PUSH P,A8 ; en negatif (a code des G.C.).
MOVEM A2,LASTRD ; SAUVE LASTREAD.
PUSH P,[READM5] ; PREPARE RETOUR.
CAML A7,ELIST ; CODE ?
JRST (A7) ; OUAIP = ON Y VA.
MOVE A1,A7 ; NON = PREPARE APPLY.
SETZ A4,
JRST APPLY
READM5:
POP P,A8 ; recupere la profondeur.
MOVNM A8,DPREAD ; elle etait negative.
POP P,A2 ; enfin depile LAST.
READM6:
SETZ A8, ; TYPE == ATOM.
POPJ P,
MQUOTE: ; MACRO ' (QUOTE).
PUSHJ P,READ
CONSL A1,A1,NIL
HRLI A1,QUOTE
CONSL A1,,
POPJ P,
MOCTAL: ; MACRO \ MODE OCTAL.
MOVN A5,IBASE ; sauve IBASE NEG
PUSH P,A5 ; a cause des G.C.
MOVN A5,IBASEX ; sauve l'instruction de conversion d'entree.
PUSH P,A5 ; NEG aussi (y peut yavoir IMUL ou LSH).
; IMUL=220, LSH=242.
MOVEI A5,10
MOVEM A5,IBASE ; IBASE = 8(10).
MOVE A5,[LSH A5,3] ; prepare l'instruction de decalage.
MOVEM A5,IBASEX ; que l'on range.
PUSHJ P,READ ; lecture d'uns S-expr qcq.
POP P,A5 ; restaure IBASEX.
MOVNM A5,IBASEX
POP P,A5 ; restaure IBASE.
MOVNM A5,IBASE
POPJ P,
; IN : TEREAD READCH PEEKCH
; (TEREAD) [0SUBR] termine l'enregistrement.
TEREAD: ; FIN ENREGISTREMENT LOGIK.
PUSHJ P,@INCHAR
SKIPE A1,TABCAR(A7) ; A1 <- TYPE.
JRST TEREAD ; C'EST PAS UN BREAK.
POPJ P, ; RAMENE NIL.
; (READCH) [0SUBR] ramene le caractere suivant.
READCH: ; RAMENE LE CARACTERE SUIVANT.
PUSHJ P,@INCHAR
SKIPN TABCAR(A7)
JRST READCH ; C'EST UN BREAK.
PJRST CRACAR ; CRE L'ATOME MONO-CARACTERE.
; (PEEKCH) [0SUBR] regarde le caractere suivant.
PEEKCH: ; REGARDE LE CARACTERE SUIVANT.
PUSHJ P,@INCHAR
SKIPN TABCAR(A7)
JRST PEEKCH ; C'EST UN BREAK.
MOVEM A7,CONSER ; POUR LE REGURGITER.
PJRST CRACAR ; CRE L'ATOME MONO-CARACTERE.
; IN : IMPLODE
; (IMPLODE l) [1SUBR] Cette fonction s'appelle parfois READLIST.
; interne la liste de caractere l ou la chaine str.
; ramene NIL si c'est un atome ou un nb.
IMPLODE::
CAMGE A1,BSTRG
PJRST FALSE ; si atome ou nb.
CAMGE A1,BLIST ; si liste c'est pret
GETCDR A1,A1 ; si str on prend la.liste des caracteres.
PUSH P,A1 ; sauve l contre les G.C.
MOVEM A1,IMPLOL ; pourIMPLC.
PUSH P,INCHAR ; sauve l'ancienne adresse.
MOVEI A5,IMPLC ; force la nouvelle adresse.
MOVEM A5,INCHAR
MOVE A5,CONSER ; sauve le vieux CONSER.
MOVEM A5,IMPLOC
SETZM CONSER
SETBIT IBIT30 ; into IMPLODE.
PUSHJ P,READ ; READLIST.
CLRBIT IBIT30 ; on est pu dans IMPLODE.
MOVE A5,IMPLOC ; recupere le vieux CONSER
MOVEM A5,CONSER
POP P,INCHAR ; reactualise INCHAR.
POP P,A2 ; recupere l.
POPJ P, ; voila.
; routine qui remplace GETCH appelle par PUSHJ P,@INCHAR
; doit mettre dans A7 le caractere suivant
IMPLC:
SKIPE A7,CONSER ; ya deja qcq
JRST IMPLC9 ; on le prend et on efface CONSER.
MOVE A8,IMPLOL ; recup la liste des caracteres.
JPNIL A8,IMPLC8 ; c'est la fin.
JNLIST A8,ERLC08 ; y fo une liste.
UNCONS A8,A7,A8 ; A7 <- atome suivant.
MOVEM A8,IMPLOL ; sauve le reste.
IMPLC1:
CAMGE A7,BSTRG
JRST IMPLC2 ; si atome ou nb.
CAML A7,BLIST
JRST ERLC09 ; une liste est une erreur.
GETCDR A7,A7
GETCAR A7,A7 ; A7 <- 1er caracere de la chaine.
JRST IMPLC1 ; que l'on reteste.
IMPLC2: ; cas atome ou nombre.
JPATOM A7,IMPLC3 ; si atome litteral.
MOVE A7,MEM(A7) ; A7 <- la val du nb.
ADDI A7,"0" ; effectue la conversion.
ANDI A7,177 ; on sait jamais.
POPJ P, ; c'est tout bon.
IMPLC3: ; cas atome litteral.
LDB A7,[POINT 7,MEM+1(A7),13]
POPJ P,
IMPLC8: ; fin 1ere liste.
MOVEI A7,T ; pour provoquer une ERLC la prochaine fois.
MOVEM A7,IMPLOL
MOVEI A7," " ; rameme le dernier separateur.
POPJ P, ; voila
IMPLC9:
SETZM CONSER ; on l'efface
POPJ P, ; tout est dit.
SUBTTL FONCTIONS DE SORTIE
$$OUT::
PRINTX /6-SORTIE/
;********************************************************************
;
; S O R T I E
;
;********************************************************************
;
; O U T B U F : met RC/LF en fin de buffer,
; IMPRIME LE BUFFER,
; RAZ LE BUFFER,
; REINITIALISE LE PIONTEUR.
;
; APPEL : PUSHJ P,OUTBUF
$TERPRI:: ; (TERPRI) [0SUBR] compilateur.
SETZ A1, ; ca doit ramener NIL.
OUTBUF:
AOS A3,BUFOUP ; A3,BUFOUP <- BUFOUP+1.
MOVEI A4,15 ; A4 <- "RC".
MOVEI A5,12 ; A5 <- "LF".
DMOVEM A4,BUFOUT-1(A3) ; charge RC/LF.
OUTBU0:
MOVNI A3,2 ; pour le prefixe.
OUTBU1:
SOSG OBLK+2 ; fin du buffer systeme ?
PUSHJ P,OUTBU3 ; ouaip.
MOVE A4,BUFOUT(A3) ; transfert de 1 caractere.
IDPB A4,OBLK+1 ;
CAMGE A3,BUFOUP ; fin de BUFOUT ?
AOJA A3,OUTBU1 ; nan.
MOVE A5,[XWD BUFOUB,BUFOUT] ; remise a blanc du buffer.
BLT A5,BUFOUL-1
MOVEMM PRMARG,A5,BUFOUP ; init de BUFOUT.
ADDI A5,1
SNBIT IBIT20 ; y fo pas ecrire en fin de ligne.
OUTBU3:
OUT CHOUT, ; impression du buffer systeme.
POPJ P, ; tout va bien.
HALT REENTE ; ya un sac !
AOUTBF: EXP OUTBUF ; adresse de OUTBUF (qui est une UUO !!).
; OUT : PRBPN
;
; P R B P N : EDITE UNE STRING - PNAME
; - NOMBRE.
; ENTREE : A6 := POINTEUR DE LA SRTING.
;
PRPA1:
MOVE A6,[POINT 7,MEM+1(A1),6]
PRBPN:
MOVEM A6,PSTR ; SAUVE POINTEUR STRING.
LDB A6,PSTR ; RAMASSE LONGUEUR STRING.
ADD A6,BUFOUP ; CA RENTRE
CAML A6,BUFOUL ; DANS LA LIGNE ?
PUSHJ P,OUTBUF ; NAN.
MOVE A5,BUFOUP ; A5:=POINTEUR BUFFER.
PRBPN1:
ILDB A7,PSTR ; A7:=CARACTERE A CHARGER.
JUMPE A7,PRBPN2 ; SI C'EST FINI.
MOVEM A7,BUFOUT(A5) ; CHARGE CARACTERE.
AOJG A5,PRBPN1 ; AU SUIVANT.
PRBPN2:
MOVEM A5,BUFOUP ; SAUVE POINTEUR BUFOUT.
POPJ P,
; OUT : PRCHT PRSPAC PRCH et la fonction OUTBUF
; EDITE LA CARACTERE -> A7 COMME SI C'ETAIT UN ATOME
; IL TESTE SI I FO UN ESPACE.
PRCHT:
SKIPN PRTYPE
PJRST PRCH ; Y FO PAS D'ESPACE AVANT.
PUSH P,A7 ; SAUVE LE CARACTERE.
PUSHJ P,PRSPAC
POP P,A7 ; RESTORE LE CARACTERE.
SETZM PRTYPE ; INDIC PAS D'ESPACE AVANT.
PJRST PRCH ; EDITE A7.
; P R S P A C : EDITE UN ESPACE SI C'EST POSSIBLE sinon TERPRI.
PRSPAC:
JNBIT IBIT25,VPOPJ ; PAS D'ESPACE ENTRE ATOME.
MOVEI A7," "
AOS A5,BUFOUP ; INCREM POINTEUR.
CAMLE A5,BUFOUL ; CA RENTRE ?
JRST OUTBUF ; NAN.
JRST PRCH1 ; OUAIP.
; P R C H : EDITE LE CARACTERE DANS A7 .
PRCH0:
PUSHJ P,OUTBUF
PRCH:
AOS A5,BUFOUP ; A5,BUFOUP := BUFOUP+1 .
CAMLE A5,BUFOUL ; CA RENTRE ?
JRST PRCH0 ; NAN.
PRCH1:
CAIN A7,15 ; C'EST UN RETURN ?
JRST 0,OUTBUF ; EQUIVALENT A RC.
MOVEM A7,BUFOUT-1(A5) ; RANGE CARACTERE.
POPJ P, ; VOILA.
; (OUTBUF adr val) [2SUBR]
FOUTBF:
MOVE A5,MEM(A1) ; val de l'adresse.
CAIL A5,0
CAML A5,BUFOUL ; ca rentre dans la ligne ?
POPJ P, ; nan : y donc rien a faire.
JPNIL A2,FOUTB1 ; ya ps de 2eme arg.
MOVE A7,MEM(A2) ; pour CONVB0.
SNATOM A2
SKIPA A6,[POINT 7,MEM+1(A2),13]
PUSHJ P,CONVB0
ILDB A7,A6 ; A7 <- le caractere.
MOVEM A6,BUFOUT(A5) ; force le nouveau caractere.
FOUTB1: MOVE A7,BUFOUT(A5) ; ramene le caractre.
PJRST CRACAR
; OUT : CONVBD CONVB0 CONVD0
; C O N V B D - CONVERSION BINAIRE DCEIMAL -
; ENTREE A1 <- ATOME NUMERIQUE.
; SORTIE A6 <- POINTEUR STRING.
; CONVD0 suppose dans A7 un nb qui est convertit en decimal.
CONVD0: ;;; la base de sortie est tjrs 10.
PUSH P,OBASE ; sauve l'ancienne base.
MOVEI A6,↑D10 ; maintenant du decimal.
MOVEM A6,OBASE
PUSHJ P,CONVB0 ; on convertit A7.
POP P,OBASE ; restaure l'ancienne base.
POPJ P, ; voila.
CONVBD: ;;; conversion de A1.
MOVE A7,MEM(A1) ; recupere la valeur du nombre.
CONVB0: ;;; on suppose le nombre deja dans A7.
SETZB A5,PRSTRG ; raz nb decar ascii et le 1er mot.
SETZM PRSTRG+1 ; raz aussi le 2eme (voir G.C.).
MOVE A6,[POINT 7,PRSTRG,6]
JNBIT IBIT23,CNVBD1 ; on traite pas le signe - .
CNVBDE:
JUMPGE A7,CNVBD1
MOVEI A8,"-" ; SI NB NEGATIF.
IDPB A8,A6
ADDI A5,1
MOVN A7,A7 ; NEGATE NB.
CNVBD1:
PUSHJ P,CNVBD2 ; APPEL CONV
IDPB A7,A6 ; FORCE UN (0)ASCII.
MOVE A6,[POINT 7,PRSTRG,6]
DPB A5,A6 ; CHARGE LE NB DE CAR ASCII.
POPJ P, ; VOILA A6 CONTIENT LE POINTEUR !!
CNVBD2:
IDIV A7,OBASE
HRLM A7+1,(P) ; SAUVE LE RESTE.
ADDI A5,1
SKIPE A7
PUSHJ P,CNVBD2
HLRZ A8,(P) ; RECUP LES RESTES.
ADDI A8,"0"
CAILE A8,"9" ; C'EST HEXA ?
ADDI A8,7 ; OUAIP.
IDPB A8,A6 ; CHARGE CARACTERE.
POPJ P,
; OUT : CNVFLT CONVNB
; conversion d'un nombre flottant A1.
; rameme dans A6 le pointeur de chaine tout pret (comme CONVBD)
CNVFLT:
MOVE A7,MEM(A1) ; recupere la valeur.
JUMPE A7,CONVB0 ; 0 is 0 (c'est + rapide et - dangeureux).
MOVE A6,[POINT 7,PRSTRG,6] ; init pointeur string.
SETZ A5, ; raz le nb de caracteres ASCII.
JUMPG A7,CNVF1 ; si le nb est positif.
MOVNS A7 ; negate le nb.
MOVEI A4,"-" ; edite le caractere "-".
IDPB A4,A6
ADDI A5,1 ; incr le nb de car ASCII.
CNVF1:
MOVEI A4,7 ; init pour l'exposant.
TLNN A7,377000 ; c'est bien un nb flottant ?
JRST CNVBD1 ; edite en fixe.
CNVF2:
CAML A7,[999999.5] ; normalisation.
JRST CNVF3
FMPR A7,[10.0]
SOJA A4,CNVF2
CNVF3:
CAMGE A7,[9999999.5] ; ca continue.
JRST .+3
FDVR A7,[10.0]
AOJA A4,CNVF3
CAIG A4,7
JUMPGE A4,CNVF4 ; exposant entre -1 et 5; sinon,
SUBI A4,1 ; on remet le vrai exposant.
PUSH P,A4 ; on le sauve.
MOVEI A4,1
PUSHJ P,CNVF6 ; edite la mantisse.
MOVEI A8,"E"
IDPB A8,A6
ADDI A5,1
POP P,A7
JRST CNVBDE ; edite l'exposant (avec signe).
CNVF4:
JUMPN A4,CNVF5 ; exposant = -1.
PUSHJ P,CNVF11 ; edite "0."
PUSHJ P,CNVF10
CNVF5:
PUSHJ P,CNVF6 ; edite la mantisse
SOJL A4,CNVF99 ; c'est fini,
PUSHJ P,CNVF11 ; sinon edite les trailing 0.
SOJGE A4,.-1
PUSHJ P,CNVF10
JRST CNVF99
CNVF6:
FIXR A7,A7 ; fixe et arrondi la mantisse.
CNVF7: ; convert dec simple.
IDIVI A7,↑D10
JUMPE A7,CNVF9 ; c'est fini.
JUMPE A7+1,CNVF7
JRST CNVF9
CNVF8:
IDIVI A7,↑D10
CNVF9:
HRLM A7+1,(P)
SKIPE A7
PUSHJ P,CNVF8
HLRZ A7+1,(P)
ADDI A8,"0"
SOJN A4,CNVF12 ; edite le car.
PUSHJ P,CNVF12 ; puis
CNVF10: ; edite un ".".
MOVEI A8,"."
JRST CNVF12
CNVF11: ; edite un "0".
MOVEI A8,"0"
CNVF12: ; edite le car in A8.
IDPB A8,A6
ADDI A5,1 ; incr nb de car ASCII.
POPJ P,
CNVF99: ; fin de la conversion.
SETZB A8,A4 ; force un 0 en fin buffer.
IDPB A8,A6
MOVE A6,[POINT 7,PRSTRG,6]
DPB A5,A6
POPJ P, ; A6 contient le pointeur.
; CONVNV : conversion d'un nb ds A1 (appel de CONVBD ou CONVFLT)
CONVNB:
CAML A1,BCNUM
SKIPN MEM+1(A1) ; test type.
PJRST CONVBD ; nb fixe.
PJRST CNVFLT ; nb float.
; OUT : PRATOM (litatom)
;
; P R A T O M : EDITE UN ATOME ( DANS A1 )
;
PRATOM:
SKIPE PRTYPE ; SKIP SI PRECEDENT = "(" .
PUSHJ P,PRSPAC ; AJOUTE 1 ESPACE.
SETOM PRTYPE ; C'EST PAS UNE "(" .
;;; CAS ATOME ALPHA.
JNATOM A1,PRATO1 ; ATOME ALPHA.
MOVEI A5,(A1) ; teste si c'est bien le debut
IDIVI A5,SIZAT ; d'un atome.
JUMPN A6,PRIN2 ; imprime donc en CODE style.
MOVE A6,[POINT 7,MEM+1(A1),6]
JNBIT IBIT24,PRBPN ; PAS DE QUOTEC.
MOVEM A6,PSTR
SETZ A5, ; NB DE CARACTERES.
MOVE A6,[POINT 7,PRSTRG,6]
JRST PRAT2
PRAT1: ; CHARGE LE CARACT.
IDPB A7,A6
ADDI A5,1
PRAT2:
ILDB A7,PSTR
JUMPE A7,PRAT3 ; FIN PNAME.
MOVE A8,TABCAR(A7) ; RECUP TYPE CAR.
CAIE A8,2 ; NORMAL ?
JRST PRAT29 ; NAN.
CAME A7,QUOTEC
CAMN A7,COMMENT
JRST PRAT29
CAME A7,CSTRIN
JRST PRAT1
PRAT29:
MOVE A8,QUOTEC ; "/" .
IDPB A8,A6
AOJA A5,PRAT1
PRAT3:
IDPB A7,A6 ; FORCE (0)8.
MOVE A6,[POINT 7,PRSTRG,6]
DPB A5,A6 ; FORCE NB CARACT.
JRST PRBPN
; OUT : PRATOM (nombres et chaines)
PRATO1: ;;; cas nombre.
CAML A1,BSTRG
JRST PRATO2
CAMGE A1,BCNUM ; si nb fixe,
JRST PRATN1 ; on le convertit tout de suite.
TRNE A1,1 ; est-ce bien un nb ?
JRST PRIN2 ; CODE style.
SKIPE MEM+1(A1) ; nb fixe ?
JRST PRATN2 ; nan
PRATN1: ; : nb fixe.
PUSHJ P,CONVBD
JRST PRBPN
PRATN2:
PUSHJ P,CNVFLT ; conversion flottante.
JRST PRBPN
PRATO2: ;;; CAS CHAINE.
GETCDR A1,A5 ; A5 <- la liste des caracteres.
MOVEI A6,2 ; calcul Plength.
GETCDR A5,A5
CAML A5,BLIST
AOJA A6,.-2
ADD A6,BUFOUP ; ca rentre dans la
CAML A6,BUFOUL ; ligne ?
PUSHJ P,OUTBUF ; nan : vide le buffer.
PUSHJ P,PRCSTR ; EDITE LE SEPARAT.
GETCDR A1,A1 ; RECUP LISTE DES CARACTERES.
JPNIL A1,PRCSTR ; CHAINE VIDE "".
PRAT51:
UNCONS A1,A2,A1
JNNUMB A2,PRAT53 ; C'EST PAS UN NB.
MOVE A7,MEM(A2) ; RECUP SA VALEUR.
ADDI A7,"0" ; CONVERTIT ASCII.
JRST PRAT55
PRAT53:
LDB A7,[POINT 7,MEM+1(A2),13] ; RECUP 1ER CARACT PNAME.
CAMN A7,CSTRIN ; C'EST LE SEPARATEUR ?
PUSHJ P,PRCSTR ; OUI : JE LE DOUBLE.
PRAT55:
PUSHJ P,PRCH
JNNIL A1,PRAT51 ; LA CHAINE CONTINUE.
PRCSTR: ;;; EDITE LE SEPARATEUR
JNBIT IBIT27,VPOPJ ; YFOPAS LE RESTITUER.
MOVE A7,CSTRIN
PJRST PRCH
; OUT : PRIN1
; PRIN1 : edite l'objet A1 et ramene A1.
$PRIN1:: ; (PRIN1 s) [1SUBR] compilateur.
PRIN1:
PUSH P,A1 ; SAUVE L'ARGUMENT ET
PUSH P,[A1.P] ; PREPARE LE RETOUR.
SETZM PRTYPE ; PRECED # ( => PAS D'ESPACE.
MOVE A7,PRDPM ; initialise la
MOVEM A7,PRDPC ; profondeur courante.
SNBIT IBIT21 ; 1 ESPACE AVANT IMPRESSION ?
PUSHJ P,PRSPAC ; OUAIP.
PRIN11:
JUMPL A1,PRIN2 ; adresse negative ?!?
JNLIST A1,PRATOM ; ATOME TRES NORMAL.
CAMGE A1,ELIST ; C'EST DU CODE.
JRST PRIN3 ; C'EST DE LA LISTE.
PRIN2: ;;; ADRESSE CODE.
; adresse utile pour PRATOM.
PUSH P,A1 ; ON LA SAUVE.
MOVEI A7,"\"
PUSHJ P,PRCHT ; IMPRIME "\".
POP P,A7
PUSH P,OBASE ; SAUVE LA BASE DE SORTIE
MOVEI A5,10 ; ON LA MET A (10)8.
MOVEM A5,OBASE
PUSH P,RG ; sauve le R.G.
; CLRBIT IBIT23 ; on inhibe le signe -.
; ca va pas car ca declenche un autre ** arith excep.
PUSHJ P,CONVB0
POP P,RG ; restaure le R.G.
POP P,OBASE ; RESTORE LA BASE.
PJRST PRBPN ; EDITE LE NB CONVERTI.
PRIN3: ;;; CAS LISTE.
SOSL PRDPC ; pronf max atteinte ?
JRST PRIN30 ; nan.
AOS PRDPC ; defait de decremntAtion.
MOVEI A1,A.ET ; imprime l'atome &
PJRST PRATOM ; a la place.
PRIN30: JNBIT IBIT26,PRIN8 ; Y FO PAS TRAITER LES MACRO-FN DE SORTIE.
GETCAR A1,A4 ; RECUP LE CAR DE LA LISTE A IMPRIMER.
JNATOM A4,PRIN8 ; PEUT PAS ETRE UNE MACRO-FN.
;;; RECHERCHE D'UNE MACOUT.
MOVEI A5,(A4) ; POUR PAS TOUCHER A A4.
PRIN41:
GETCDR A5,A5
JPNIL A5,PRIN5 ; LISTE VIDE.
UNCONS A5,A6,A5
CAIN A6,MACOUT ; TESTE DE L'INDICATEUR.
JRST PRIN42 ; JE L'AI !
JNNIL A5,PRIN41 ; LA P-LISTE CONTINUE.
JRST PRIN5 ; FIN P-LISTE AU MILIEU ?!?
PRIN42:
GETCAR A5,A4 ; PREPARE POUR APPLY.
GETCDR A1,A1
EXCH A1,A4
PJRST APPLY
; OUT : PRIN1 (suite)
PRIN5: ;;; MACOUT STANDARD ' [ ] .
CAIE A4,QUOTE
JRST PRIN51
GETCDR A1,A2 ; CAS (QUOTE ... ) .
GETCDR A2,A3
JNNIL A3,PRIN8 ; C'EST PAS LA FN QUOTE A 1 ARGUMENT.
GETCAR A2,A2
PUSH P,A2 ; SAUVE L'ARGUMENT.
AOS PRDPC ; repositionne la profond courante.
MOVEI A7,"'"
PUSHJ P,PRCHT
POP P,A1 ; RECUP L'ARGUMENT.
JRST PRIN11 ; ET L'IMPRIME.
PRIN51:
CAIE A4,A.LIST
JRST PRIN8
GETCDR A1,A1 ; CAS (LIST E1 ... EN) .
MOVEI A7,"["
PUSHJ P,PRIN9
SETOM PRTYPE
MOVEI A7,"]"
PJRST PRCH
PRIN8: ;;; CAS ( ... LISTE NORMALE ... ) .
MOVEI A7,"("
PUSHJ P,PRIN9
SETOM PRTYPE
MOVEI A7,")"
PJRST PRCH
PRIN9: ;;; EDITE LES ELEMENTS DE LA LISTE A1.
PUSHJ P,PRCHT ; EDITE LE 1ER SEPARATEUR QUI EST DS A7.
JPNIL A1,VPOPJ ; POUR LE CAS []
MOVE A7,PRLNM ; actualise le nb d'elements
MOVEM A7,PRLNC ; imprimes courant.
PRIN91:
SOSL PRLNC ; decremente le nb d'elem
JRST PRIN93 ; yen a pas assez d'imprimes.
MOVE A6,[POINT 7,[BYTE (7)3,".",".","."],6]
PJRST PRBPN ; ... a la place
PRIN93:
UNCONS A1,A1,A2
PUSH P,A2 ; SAUVE LE CDR.
PUSHJ P,PRIN11 ; IMPRIME LE CAR
POP P,A1 ; RESTORE LE CDR
JPLIST A1,PRIN91 ; LA LISTE CONTINUE.
AOS PRDPC ; remonte de la pronf courante.
JPNIL A1,VPOPJ ; PAS DE PAIRE POINTEE.
SETOM PRTYPE ; POUR L'ESPACE APRES.
PUSHJ P,PRSPAC ; TJRS 1 ESPACE AVANT "."
MOVEI A7,"."
PUSHJ P,PRCH
PJRST PRATOM ; EDITE LA PARTIE DROITE ET RETOUR.
; OUT : PRINT PRINTU PRIN1U TERPRI TTAB
; P R I N T : IMPRIME L'OBJET A1 .
; RAMEME A1 EN VALEUR.
$PRINT::
PRINT:
PUSHJ P,PRIN1 ;
JRST OUTBUF ;
; (PRIN1 S1 ... SN) et (PRINT S1 ... SN) [NSUBR]
PRINTU:
PUSH P,AOUTBF ; prepare le OUTBUF final.
PRIN1U:
UNCONS A4,A1,A4
PUSH P,A4
PUSHJ P,PRIN1
POP P,A4
JNNIL A4,PRIN1U ; ya encore des choses a sortir.
POPJ P,
; T E R P R I : termine l'impression .
; ramene A1 en valeur. [1SUBR]
TERPRI:
JNNUMB A1,OUTBUF ; c'est pas un nb.
MOVE A6,MEM(A1) ; val de l'arg.
JUMPL A6,OUTBU0 ; pas de mouvemnet de papier.
MOVE A5,BUFOUP
MOVEI A7,15 ; return.
MOVEM A7,BUFOUT(A5)
MOVEI A7,12 ; L.F.
JUMPLE A6,OUTBU0 ; surimpression.
TERPR1:
AOS A5,BUFOUP
MOVEM A7,BUFOUT(A5)
SOJG A6,TERPR1
JRST OUTBU0
; (TTAB N) [1SUBR]
TTAB:
MOVE A5,MEM(A1)
JUMPL A5,VPOPJ ; N negatif.
CAMG A5,BUFOUL
MOVEM A5,BUFOUP
POPJ P,
; OUT : PRINC SPACES PAGE PRINTLEVEL PRINTLENGTH
; (PRINC CH [N]) [2SUBR]
; edite N (ou 1) fois le caractere CH.
$PRINC:: ; (PRINC c) [1SUBR] compilateur.
SETZ A2,
PRINC:
SNATOM A1
SKIPA A6,[POINT 7,MEM+1(A1),6] ; si litatom.
PUSHJ P,CONVBD ; si nombre.
ILDB A7,A6 ; A7 <- le caractere.
PRINC1:
MOVE A8,MEM(A2) ; A8 <- le nombre de fois.
PUSHJ P,PRCH
SOJG A8,.-1 ; PRCH ne touche pas a A8.
POPJ P,
; (SPACES [N]) [1SUBR] edite N espaces.
$SPACES:: ; (SPACES) [0SUBR] compilateur.
TDZA A2,A2 ; A2 <- 0 et skip.
SPACES:
MOVEI A2,(A1)
MOVEI A7," "
JRST PRINC1
; (PAGE) [0SUBR] saut de page en sortie.
APAGE:
MOVEI A7,14 ; Form Feed.
AOS A5,BUFOUP ; recup le pointeur du buffer sortie.
MOVEM A7,BUFOUT(A5) ; force le caractere FF.
JRST OUTBU0 ; vide la ligne.
; (PRINTLEVEL n) [1SUBR]
PRLVL:
JPNIL A1,PRLV1 ; ya pas d'arg transmit.
MOVE A5,MEM(A1) ; A1 <- val de l'arg numerique.
MOVEM A5,PRDPM ; change la profondeur max du PRINT.
PRLV1:
MOVE A5,PRDPM ; ramene le val courante
PJRST CRANUM
; (PRINTLENGTH n) [1SUBR]
PRLNG:
JPNIL A1,PRLN1 ; ya pas d'arg transmit.
MOVE A5,MEM(A1) ; A1 <- val de l'arg transmit.
MOVEM A5,PRLNM ; change la longeur courante.
PRLN1:
MOVE A5,PRLNM ; ramene la valeur courante.
PJRST CRANUM
SUBTTL ERREURS
;********************************************************************
; E R R E U R S
;********************************************************************
; debordement des zones
ERAT:
PUSH P,[POINT 7,[BYTE (7)↑D25,15,12," "," "
ASCIZ /** no room for atoms./],6]
JRST ERRP
ERATN:
PUSH P,[POINT 7,[BYTE (7)↑D27,15,12," "," "
ASCIZ /** no room for numbers./],6]
JRST ERRP
ERATS:
PUSH P,[POINT 7,[BYTE (7)↑D27,15,12," "," "
ASCIZ /** no room for strings./],6]
JRST ERRP
ERFM: PUSH P,[POINT 7,[BYTE (7)↑D25,15,12," "," "
ASCIZ /** no room for lists./],6]
JRST ERRP
ERARR:
PUSH P,[POINT 7,[BYTE (7)↑D26,15,12," "," "
ASCIZ /** no room for arrays./],6]
JRST ERRP
ERCOD:
PUSH P,[POINT 7,[BYTE (7)↑D24,15,12," "," "
ASCIZ /** no room for code./],6]
JRST ERRP
ERSO::
PUSH P,[POINT 7,[BYTE (7)33,15,12," "," "
ASCIZ /** user stack overflow./],6]
JRST ERRP
ERSU::
PUSH P,[POINT 7,[BYTE (7)34,15,12," "," "
ASCIZ /** user stack underflow./],6]
JRST ERRP
; ERR : messages (ERLC)
ERLC01: ; 1er objet = .
MOVEI A6,1
JRST ERLC
ERLC02: ; 1er objet = )
MOVEI A6,2
JRST ERLC
ERLC03: ; 1er objet = ]
MOVEI A6,3
JRST ERLC
ERLC04: ; . au milieu d'une liste
MOVEI A6,4
JRST ERLC
ERLC05: ; . xx ] sans [
MOVEI A6,5
JRST ERLC
ERLC06: ; ] sans [
MOVEI A6,6
JRST ERLC
ERLC07: ; ) sans (
MOVEI A6,7
JRST ERLC
ERLC08: ; fin de liste IMPLODE
MOVEI A6,8
JRST ERLC
ERLC09: ; mauvais caractere IMPLODE.
MOVEI A6,9
JRST ERLC
ERLC:
MOVE A1,PZER ; interne le numero d'erreur.
ADD A1,A6 ; c'est ose mais c'est comme ca kifofere.
MOVEI A5,GETCH ; dans tous les cas je repositionne
MOVEM A5,INCHAR ; l'adresse standard de lecture.
JNBIT IBIT30,ERLC0 ; on est pas dans IMPLODE.
PUSH P,[POINT 7,[BYTE (7)↑D22,15,12," "," "
ASCIZ /** IMPLODE error :/],6]
JRST ERRPA1
ERLC0:
TXZE RG,IBIT31 ; en fonction du into LIBRARY.
JRST ERLC1
PUSH P,[POINT 7,[BYTE (7)↑D19,15,12," "," "
ASCIZ /** READ error :/],6]
JRST ERRPA1
ERLC1: ;;; j'etais dans LIBRARY.
MOVE A6,[POINT 7,[BYTE (7)↑D28,15,12," "," "
ASCIZ /** READ error (in LIBRARY) :/],6]
CLOSE CHLIB, ; y vaut mieux tout fermer.
RELEAS CHLIB,
JRST LIBNX0 ; vers la fermeture de la file.
; ERR : messages (suite)
LIBPER:
PUSH P,[POINT 7,[BYTE (7)23,15,12," "," "
ASCIZ /** LIBRARY error : /],6]
JRST ERRPA1
ERA8:
PUSH P,[POINT 7,[BYTE (7)34,15,12," "," "
ASCIZ /** undefined variable : /],6]
GETCAR A4,A1 ; A1 <- le nom de l'atome.
JRST ERRPA1
ERA9:
PUSH P,[POINT 7,[BYTE (7)43,15,12," "," "
ASCIZ /** undefined function (EVAL) : /],6]
GETCAR A4,A1 ; A1 <- le nom de la fonction.
JRST ERRPA1
ERA2:
PUSH P,[POINT 7,[BYTE (7)44,15,12," "," "
ASCIZ /** undefined function (APPLY) : /],6]
JRST ERRPA1
ERSUBR:
PUSH P,[POINT 7,[BYTE (7)43,15,12," "," "
ASCIZ /** undefined function (SUBR) : /],6]
JRST ERRPA1
ERFSUB:
PUSH P,[POINT 7,[BYTE (7)44,15,12," "," "
ASCIZ /** undefined function (FSUBR) : /],6]
JRST ERRPA1
ERSELF:
PUSH P,[POINT 7,[BYTE (7)↑D18,15,12," "," "
ASCIZ /** SELF error./],6]
JRST ERRP
ERLESC:
PUSH P,[POINT 7,[BYTE (7)25,15,12," "," "
ASCIZ /** LESCAPE error./],6]
JRST ERRP
ERESCP:
PUSH P,[POINT 7,[BYTE (7)25,15,12," "," "
ASCIZ /** ESCAPE error : /],6]
JRST ERRPA2
ERRT:
PUSH P,[POINT 7,[BYTE (7)26,15,12," "," "
ASCIZ /** RETURN error./],6]
JRST ERRP
ERCYCLE:
PUSH P,[POINT 7,[BYTE (7)23,15,12," "," "
ASCIZ /** CYCLE error./],6]
JRST ERRP
ERGOTO:
PUSH P,[POINT 7,[BYTE (7)25,15,12," "," "
ASCIZ /** LABEL error : /],6]
JRST ERRPA2
ERBDEF:
PUSH P,[POINT 7,[BYTE (7)↑D22,15,12," "," "
ASCIZ /** bad definition./],6]
JRST ERRP
ERUS:
PUSHJ P,EPROGN
PUSH P,[POINT 7,[BYTE (7)24,15,12," "," "
ASCIZ /** user ERROR : /],6]
JRST ERRPA1
ERGC:
PUSH P,[POINT 7,[BYTE (7) 26,15,12," "," "
ASCIZ /** G.C. step done./],6]
JRST ERRP
ERUUO:
POP P,A1 ; recupere l'adresse de ret de l'UUO.
PUSH P,[POINT 7,[BYTE (7)↑D19,15,12," "," "
ASCIZ /** illegal UUO./],6]
JRST ERRPA1
ERST:
PUSH P,[POINT 7,[BYTE (7)26,15,12," "," "
ASCIZ /** STATUS error : /],6]
JRST ERRPA1
; ERR : impression et backtrace.
ERRPA2:
MOVEI A1,(A2)
ERRPA1:
SKIPA A2,[PRINT]
ERRP:
MOVEI A2,OUTBUF
PUSHJ P,OUTBUF
POP P,A6
PUSHJ P,PRBPN
PUSHJ P,(A2)
REENTE:: ;;; REE en cas d'erreur.
JNBIT IBIT6,REENT ; le backtrace n'est pas actif.
MOVEI A5,"*" ; prfixe d'impression d'erreur.
MOVEM A5,PRPREF
MOVE A6,[POINT 7,[BYTE (7)↑D15,"-","-","-"," "
ASCIZ /Last Form= /],6]
PUSHJ P,PRBPN
MOVE A1,LFORME ; recup la derniere forme evaluee.
PUSHJ P,PRINT ; que l'on edite.
MOVE A5,P$BIND ; yavait des lambda empilees ?
AOJGE A5,REENT ; nan : je rentre de suite.
MOVE A6,[POINT 7,[BYTE (7)↑D15,"-","-","-"," "
ASCIZ /Last Fnt = /],6]
PUSHJ P,PRBPN ; edite ce libelle.
MOVE A1,P$BIND
MOVE A1,1(A1) ; A1 <- la derniere lambda.
PUSHJ P,PRINT ; que l'on edite.
JRST REENT ; on rentre enfin...
; ERR : trap des erreurs LISP
; ERRSYS : suppose empile [ -1 ,, nom de la fnt a lancer ]
; les n 1ers arguments de la fnt
ERRSYS: ; fini d'initialiser les args.
PUSH P,LFORME ; derniere forme evaluee.
MOVE A5,P
PUSHJ P,CRANUM
PUSH P,A1 ; P lui-meme.
MOVE A5,P$BIND
PUSHJ P,CRANUM
PUSH P,A1 ; P$BIND
MOVE A5,P$LABEL
PUSHJ P,CRANUM
PUSH P,A1 ; P$LABEL.
MOVE A5,P$DO
PUSHJ P,CRANUM
; P$DO dans A1.
;;; cre la liste des args empilees.
SETZ A4, ; NIL en debut de liste.
ERRSY1:
CONSL A4,A1 ; ajoute en tete l'elem suivant.
POP P,A1 ; recup l'arg suivant.
TLZN A1,-1 ; c'set la fnt marquee ?
JRST ERRSY1 ; nan.
JRST APPLY ; tout est pret (A4 , A1) pour APPLY.
SUBTTL FONCTIONS INTERPRETE
$$INTR::
PRINTX /7-INTERPR/
IFN %IRCAM,<IRCAMP:>
TRUE:: ; pour le compilateur.
TRUTH:: ; RAMEME T.
MOVEI A1,T
POPJ P,
IFE %IRCAM,<IRCAMP:>
FALSE:: ; RAMEME NIL.
SETZ A1,
POPJ P,
VPOPJ:: ; RETURN.
POPJ P,
P.FALS:
SUB P,[1,,1]
SETZ A1, ; depile et ramene NIL.
POPJ P,
PPD.P:
SUB P,[1,,1]
PD.P:
POP P,A1
D.P:
GETCDR A1,A1
POPJ P,
A2POPJ:
MOVEI A1,(A2)
POPJ P,
A3POPJ:
MOVEI A1,(A3)
POPJ P,
PPP.P: ; == 3 POP + 1 POPJ.
SUB P,[3,,3]
POPJ P,
PP.P: ; == 2 POP + 1 POPJ.
SUB P,[2,,2]
POPJ P,
P.P: ; == 1 POP + 1 POPJ.
SUB P,[1,,1]
POPJ P,
A1.P:
POP P,A1
POPJ P,
; INTR : RETSYS RETRAC TRACES
;******************************************************************************
; I N T E R P R E T E
; APPLY EVAL EVLIS EPROGN
;******************************************************************************
RETSYT:
SETBIT IBIT8!IBIT3 ; remet l bit STEP.
RETSYS:
POP P,A6 ; ADRESSE DE STRING.
PUSHJ P,PRBPN ; EDITE STRING.
JRST PRINT ; IMPRIME A1.
; RETRAC: RETOUR EN CAS DE TRACE SUBR, FSUBR .
RETRAC:
MOVE A6,[POINT 7,[BYTE (7)5,"<","-","-","-"
ASCIZ / /],6]
PUSHJ P,PRBPN
EXCH A1,(P)
MOVE A6,[POINT 7,MEM+1(A1),6]
PUSHJ P,PRBPN
MOVE A6,[POINT 7,[BYTE (7)3," ","="," "],6]
PUSHJ P,PRBPN
POP P,A1
JRST PRINT
; TRACES: TRACE SUBR - FSUBR
; A1 <- LES ARGUMENTS.
TRACES:
EXCH A1,-1(P) ; A1 <-> FN .
PUSH P,A2 ; SAUVE ARGS DES SUBRS.
PUSH P,A3
PUSH P,A4
MOVE A6,[POINT 7,[BYTE (7)5,"-","-","-",">"
ASCIZ / /],6]
PUSHJ P,PRBPN
PUSHJ P,PRPA1 ; EDITE FN.
MOVE A6,[POINT 7,[BYTE (7)3," ",":"," "],6]
PUSHJ P,PRBPN
MOVE A1,-3(P) ; RECUP LARG.
PUSHJ P,PRINT
POP P,A4 ; RESTAURE ARGS SUBRS.
POP P,A3
POP P,A2
POP P,A1 ; DEPIL LARG.
POP P,A1
POPJ P, ; GO.
; INTR : BIND DBIND
; BIND A2 = liste des variables
; A4 = liste des nouvelles valeurs.
; A7 = type du block (MRK.xxx). [type ,, point. to end frame]
; appel: JSP L,BIND.
; empile en XWD VAL,,VAR .
BIND::
HRR A7,P ; forme [type ,, point to end frame].
PUSH P,P$BIND ; sauve stack point. of old P$BIND.
JRST BIND3
BIND2:
UNCONS A2,A5,A2 ; A5 <- VARIABLE.
PUSH P,A5 ; RH(P) <- VARIABLE.
GETCAR A5,A6 ; A6 <- OLD CVAL.
HRLM A6,(P) ; LH(P) <- OLD CVAL.
UNCONS A4,A6,A4 ; A6 <- NEW CVAL.
PUTCAR A5,A6 ; RPLACA.
BIND3:
JPLIST A2,BIND2 ; ca continue
JPNIL A2,BIND4 ; fin liste ou NIL.
PUSH P,A2 ; cas variable atome.
GETCAR A2,A5 ; recup le C-val.
HRLM A5,(P) ; on l'empile.
PUTCAR A2,A4 ; new C-val.
BIND4:
PUSH P,A7 ; empile le type du block et le point
; des co-post-recs [-n ,, point. end frame].
MOVEM P,P$BIND ; sauve le nouveau P$BIND.
JRST (L) ; retour a l'appellant.
; DBIND (destructive BIND pour
; - la fonction DO
; - les fonctions tails-recursives
; - les fonctions co-post-recursives.
; A2 = liste des variables
; A4 = liste des valeurs.
; appel : JSP L,DBIND
DBIND1::
UNCONS A2,A5,A2 ; variable suivante.
UNCONS A4,A6,A4 ; valeur suivante.
PUTCAR A5,A6 ; on change la C-valeur.
DBIND: ;;; ENTRY.
JPLIST A2,DBIND1 ; c'est une liste de variables.
JPNIL A2,(L) ; fin de la liste des variables.
PUTCAR A2,A4 ; c'est un atome unique.
JRST (L) ; retour a l'appellant.
; INTR : UNBIND
; UNBIND restaure les anciennes C-vals.
; appel: JSP L,UNBIND
UNBINP::
MOVE P,A5 ; !! suppose A5 = P$BIND !!
POP P,A6 ; recup [type block ,, point end frame].
HLRE A6,A6 ; A6 <- le type du block (tjrs negatif).
JRST UNBIND
UNBIN1: ; c'est donc un couple [val,,var]
HLLM A5,MEM(A5) ; restaure la C-val. directement.
UNBIND:
POP P,A5 ; element suivant de la pile
JUMPGE A5,UNBIN1 ; c'est pas le P$BIND.
MOVEM A5,P$BIND ; sauve le nouveau P$BIND.
AOJGE A6,(L) ; retour si block LAMBDA/GAMMA.
POP P,P$NAME ; recupere le nom du block.
AOJGE A6,1(L) ; retour si block ESCAPE.
POP P,P$LABEL ; recupere le point. sur la able des etiq.
AOJGE A6,2(L) ; retour si block PROG.
POP P,P$DO ; recupere les pointeurs des DOs.
AOJGE A6,3(L) ; retour si block DO.
POP P,P$BREAK
AOJGE A6,4(L) ; block BREAK.
HALT REENTE ; AIE!!! BUG !!!
; INTR : APPLY ;
$$APPLY::
; A P P L Y
; A1 = FN OU (LAMBDA LARG S1 ... SN)
; A4 = LISTE D'ARGUMENTS.
; table pour les lancements super-rapides.
TAPL: MEXP APPL20,AP0N,AP1,AP2,AP3,AP0N,APF,APARR
MEXP APPL20,APPL20,APPL20,APPL20,APPL20,APPL20,APPL20,APPL20
ERUDFA: ;;; erreur Undefined function apply.
PUSH P,[-1,,A.RUFA] ; prepare ERRSYS.
PUSH P,A1 ; empile le nom de la fonction.
JRST ERRSYS ; c'est envoye.
APPLYT: ;;; trace de APPLY.
JNBIT IBIT9,APPLYR ; trace non active.
PUSH P,A4 ; sauve la liste des args.
MOVE A6,[POINT 7,[BYTE (7)14,"-","-","-",">"
ASCIZ / APPLY :/],6]
PUSHJ P,PRBPN ; edite ce libelle.
PUSHJ P,PRINT ; imprime la fonction (A1).
EXCH A1,(P) ; recup les args.
MOVE A6,[POINT 7,[BYTE (7)14," "," "," "," "
ASCIZ / LARG :/],6]
PUSHJ P,PRBPN ; edite ce libelle.
PUSHJ P,PRINT ; imprime les args.
MOVEI A4,(A1) ; restaure les args.
POP P,A1 ; restaure le FN (A1).
PUSH P,[POINT 7,[BYTE (7)14,"<","-","-","-"
ASCIZ / APPLY =/],6]
PUSH P,[RETSYS] ; prepare la trace du resultat.
JRST APPLYR ; on retourne dans APPLY.
; INTR : APPLY (vrai debut) SELF et APPLYN
APPLYN: UNCONS A4,A1,A4 ; A1 <- la fnt, A4 <- les args.
JRST APPLY
APPLYU: ; *** user-apply.
MOVEI A4,(A2) ; apply recoit LARG dans A4.
JRST APPLY
SELF: ; *** entree du SELF
MOVE A5,P$BIND ; recupepe le point des BINDs.
AOJGE A5,ERSELF ; ya une lambda chargee ? nan : erreur.
SUBI A5,1 ; repositionne P$BIND.
MOVE A1,1(A5) ; A1 <- le derniere lambda.
JRST APPLY ; c'est parti.
APPLYL: ; *** APPLY 1 ARGUMENT PAS EN LISTE.
; e.g. les fonctionnelles.
CONSL A4,A4,NIL ; A4 <- (LIST A4).
APPLY:: ; *** normal ENTRY.
JPBIT IBIT4,APPLYT ; y fo tracer APPLY.
APPLYR: ; APPLY commence vraiment la.
JPATOM A1,APPLY2 ; si FN est un LITATOM.
JNLIST A1,APPLY6 ; si FN est un nombre ou une chaine, donc
APPLYY: ;;; FN est une liste.
GETCAR A1,A2 ; CAR de la FN dans A2.
CAIN A2,LAMBDA
JRST APPLY0 ; si LAMBDA.
CAIE A2,GAMMA
JRST APPLY1 ; si ni LAMBDA ni GAMMA.
GETCAR A4,A4 ; LARG <- (CAR LARG) pour GAMMA
APPLY0: ;;; commun a LAMBDA et GAMMA ;;;
HRRZ A5,(P) ; recup le sommet de pile,
; qui est l'@ de retour de APPLY.
CAIN A5,TAILRC ; on est en position tail ?
JRST APPLTR ; voire ...
APPL00:
GETCDR A1,A3 ; A3 <- ((LARG) BODY)
GETCAR A3,A2 ; A2 <- (LARG) POUR BIND.
HLROI A7, ; A7 <- -1 type block = LAMBDA [-1,,0].
JSP L,BIND
PUSH P,A1 ; sauve la LAMBDA pour les tailrecs .
GETCDR A3,A1 ; A1 <- (BODY)
JRST LESCAPE
APPLTR: ;;; traitement des tail-recursives.
CAME A1,-1(P) ; c'est la meme fonction ?
JRST APPL00 ; nan : on fait comme si de rien n'etait.
GETCDR A1,A1 ; A1 <- ((LARG) body).
GETCAR A1,A2 ; A2 <- (LARG) pour DBIND.
JSP L,DBIND ; BIND destructif.
PJRST EPROGD ; c'est quand meme plus rapide non ?
; INTR : APPLY lancements super-rapides.
APPLY1:: ;;; FN est une liste qu'est pas une LAMBDA.
PUSH P,A4 ; on sauve les arguments.
PUSHJ P,EVAL ; on evalue cette fonction.
POP P,A4 ; on restitue les arguments.
JRST APPLY ; on recommence comme si de rien n'etait.
APPLY2: ;;; FN est un atome.
HLRZ A6,MEM+4(A1) ; essaie le lancement super-rapide.
HRRZ A7,MEM+5(A1) ; adresse de lancement.
JRST @TAPL(A6) ; a dieu va...
AP0N: ;;; pour les 0SUBRs et les NSUBRs.
JRST (A7) ; on peut y aller tout de suite.
AP1: ;;; 1SUBRs.
GETCAR A4,A1 ; prepare le 1er argument.
JRST (A7) ; puis on y va.
AP2: ;;; 2SUBRs.
UNCONS A4,A1,A4 ; y fo preparer les 2 arguments,
GETCAR A4,A2 ; dans A1 et A2,
JRST (A7) ; puis on y va.
AP3: ;;; 3SUBRs.
UNCONS A4,A1,A4 ; la yen a trois a preparer.
UNCONS A4,A2,A4
GETCAR A4,A3
JRST (A7) ; puis on y va.
APF: ;;; FSUBRs.
MOVEI A1,(A4) ; compatbilite NSUBR-FSUBR.
JRST (A7) ; puis on y va.
APARR: ;;; ARRAYs.
GETCAR A4,A1 ; indice.
PUSHJ P,ELEM ; calcul de l'adresse de l'element.
MOVE A1,(A5) ; recup l'element.
POPJ P, ; voila.
; INTR : APPLY fonctions normales.
APPL20:: ;;; APPLY normal pour les fonctions
; atomiques qui ne se lancent pas facilement.
JUMPE A1,ERUDFA ; c'est NIL.
GETCDR A1,A5 ; A5 <- P-liste de l'atome.
APPLY3: ; recherche indic EXPR.
JNLIST A5,APPLY5 ; fin P-liste.
UNCONS A5,A6,A7 ; A6 = indicateur.
CAIE A6,EXPR
JRST APPLY4
GETCAR A7,A1 ; A1 <- la lambda.
JRST APPLY
APPLY4: ; continue la recherche sur la P-liste.
MOVE A5,A7
GETCDR A5,A5
JRST APPLY3
APPLY5: ;;; P-liste vide : recherche SUBR.
HLRZ A2,MEM+5(A1) ; recup indic special.
CAIN A2,SUBR ;
JRST APPLY8
CAIN A2,ARRAY
JRST APARR ; c'est un tablo.
;;; pas de proprietes : on indirecte.
GETCAR A1,A2 ; A2 <- CVAL de A1.
GETCAR A2,A5
CAIE A2,(A5) ; pour infinite loop APPLY.
CAIN A1,(A2) ; sans perdre le nom de la fonction.
JRST ERUDFA
MOVEI A1,(A2) ; c'est tout bon.
JRST APPLY ; on recommence avec trace.
APPLY6: ;;; FN = nombre ou chaine.
CAML A1,BSTRG
JRST ERUDFA ; c'est une chaine !
GETCAR A4,A2 ; POUR CNTH.
JRST CNTH ; A2 est OK.
APPLY8: ;;; lancement des SUBRs APPLY.
HRRZ A7,MEM+5(A1) ; recup l'adresse de lancement.
HLRZ A8,MEM+4(A1) ; recupere les bits speciaux.
TRZE A8,BITRAC ; y fo tracer cette SUBR ?
JRST .+3 ; he oui.
APPLY9:
PUSH P,A7 ; nan : sauve l'@ de lancemnet,
PJRST MACH ; vers le dispatch des args.
JNBIT IBIT9,APPLY9 ; trace non active.
PUSH P,A1 ; sauve FN (pour retrace).
PUSH P,[RETRAC]
PUSH P,A7 ; POUR GO.
PUSH P,[MACH]
PUSH P,A2 ; FN (POUR TRACES).
PUSH P,A4 ; ARGS (POUR TRACES).
JRST TRACES
; INTR : EVAL ;
$$EVAL::
; E V A L [1SUBR]
; dans tout EVAL - A1 est la forme.
; - A2 la fonction (CAR A1).
; - A3 les arguments (CDR A1).
; timing EVAL :
; nb ou chaine = 4.80 mic-sec. atome = 6.93 mic-sec.
; lance 0SUBR = 9.53 mic-sec, lance 1SUBR = 12.73 mic-sec
; lance FSUBR = 9.98 mic-sec.
; Idee du lancement "super-rapide" :
; les fonctions systemes ne sont pas en general redefiniees, ce n'est
; donc pas la peine qu'EVAL cherche dans la P-liste de ces atomes des
; indicateurs hypothetiques. Ceci est signale a EVAL au moyen de bits
; speciaux qui se trouvent dans la partie gauche du 5eme mot des atomes.
; Il peut y avoir comme valeur :
; - 0 je connais rien sur cette fonction.
; - 1 2 3 4 c'est une SUBR non redefinie a 0 1 2 3 arguments.
; - 5 c'est une NSUBR ; - 6 c'est une FSUBR ; - 7 c'est un tableau.
; Bien evidemment la fonction de definition REMPROP doit effacer ces
; bits speciaux si on redefinie une fonction de ce type.
; Une fonction standard doit etre tracee si le bit special 4 est present
; table pour le lancement "super-rapide"
TEVL: MEXP EVAL5,EV0,EV1,EV2,EV3,EVN,EVF,EVARR
MEXP EVAL5,EVAL5,EVAL5,EVAL5,EVAL5,EVAL5,EVAL5,EVAL5
; en cas de TRACE ;
; INTR : EVAL erreur, trace et step.
ERUDFE: ;;; UNDEFINED FUNCTION EVAL.
PUSH P,[-1,,A.RUFE]
PUSH P,A2 ; empile le nom de la fonction.
JRST ERRSYS
EVALT: ;** si trace EVAL (BIT 3) ou IT Escape-I.
JPBIT IBIT33,EVALEI ; vers le traitement de l'IT.
JNBIT IBIT9,EVALR ; traces non-actives.
MOVE A6,[POINT 7,[BYTE (7)14,"-","-","-",">"
ASCIZ / EVAL :/],6]
PUSHJ P,PRBPN
PUSH P,PRLNM ; pour l'edite de la
MOVEI A5,20 ; forme a evaluer,
MOVEM A5,PRLNM ; length print de 50.
PUSH P,PRDPM ; sauve la profond courante.
MOVEI A5,3 ; assign a 3 pour l'edition.
MOVEM A5,PRDPM
PUSHJ P,PRIN1 ; edition de la forme.
POP P,PRDPM ; restaure la pronfond max.
POP P,PRLNM ; rstaure la long max.
PUSH P,[POINT 7,[BYTE (7)14,"<","-","-","-"
ASCIZ / EVAL =/],6]
JPBIT IBIT8,EVALT2 ; le bit STEP est mis.
PUSHJ P,OUTBUF ; on est pas en STEP.
EVALT1:
PUSH P,[RETSYS] ; pour le retour de EVAL.
JRST EVALR
EVALT2: ;;; mode STEP.
PUSHJ P,OUTBU0 ; imprime physiquement.
OUTSTR [ASCIZ / !S!/] ; prompt du STEPPER.
INCHRW A8 ; lecture de la reponse au STEPPER.
PUSHJ P,OUTBUF ; de toute facon on termine la ligne.
CAIN A8,"P" ; test la commande P en capitale OU
CAIE A8,"p" ; en minuscules.
JRST EVALT3 ; c'est pas cui-la.
;; ya eu P (re-imprime la forme).
PUSHJ P,PRIN1 ; on imprime en entier.
JRST EVALT2 ; on recommence les questions.
EVALT3:
CAIN A8,15 ; test return.
JRST EVALT4 ; c'est pas ca.
CAIE A8,12 ; test line-feed.
JRST EVALT1 ; c'est donc n'importe quoi.
;; ya eu LF
CLRBIT IBIT8!IBIT3 ; enleve le step (1 coup)
PUSH P,[RETSYT] ; pour le retour d'EVAL.
JRST EVALR
EVALT4: ;; ya eu RC (arret du STEPPER).
CLRBIT IBIT8!IBIT3
JRST EVALT1
; INTR : EVAL atomes et formes simples.
EVALCA: ; *** entry (EVAL (CAR A1)).
GETCAR A1,A1
EVAL:: ; *** entry (EVAL A1).
JPBIT IBIT3!IBIT33,EVALT ; y fo tracer EVAL ou ya eu une IT ?
EVALR: ; retour de la trace.
MOVEM A1,LFORME ; sauve la forme a evaluer.
JPLIST A1,EVAL2
;;; forme atomique.
JNATOM A1,VPOPJ ; nombre ou chaine.
GETCAR A1,A1 ; A1 <- le C-val de A1.
CAIE A1,UNDEF ; atome defini ?
POPJ P, ; oui : c'est fini.
PUSH P,[-1,,A.RUBV] ; prepare l'erreur system.
JRST ERRSYS
EVAL2: ;;; forme non-atomique.
UNCONS A1,A2,A3 ; A2 <- fonction, A3 <- les args.
EVAL21:
JNATOM A2,EVAL3
;;; fonction atomique.
HLRZ A6,MEM+4(A2) ; recup les bits speciaux.
HRRZ A7,MEM+5(A2) ; recup l'@ de lancement.
JRST @TEVL(A6) ; on essaie le lancement
; super-rapide ...
EVAL3: ;;; fonction non-atomique.
JNLIST A2,EVAL35 ; cas nb ou chaine.
GETCAR A2,A4 ; A4 <- Car de la fnt.
CAIN A4,LAMBDA ; lambda expilcite ?
JRST EVLB ; evaluation rapide.
CAIN A4,GAMMA ; gamma explicite ?
JRST EVAL31 ; ouaip.
PUSH P,A3 ; sauve les args.
MOVEI A1,(A2) ; pour re-evaluer la fnt.
PUSHJ P,EVAL
MOVEI A2,(A1) ; repositionne la fnt.
POP P,A3 ; ainsi que les args.
JRST EVAL21 ; on refait de nouveau tous les tests.
EVAL31: ;;; gamma explicite.
PUSH P,A2 ; sauve la fonction.
MOVEI A1,(A3) ; prepare EVLIS.
PUSHJ P,EVLIS
MOVEI A4,(A1) ; prepare APPLY.
POP P,A1 ; recupere la fonction.
PJRST APPLYY ; apply des lambda/gamma.
EVAL35:
JNNUMB A2,ERUDFE ; la fnt est une chaine ?!?
PUSH P,A2 ; sauve ce nb.
GETCAR A3,A1 ; evalue le
PUSHJ P,EVAL ; 2eme argument.
POP P,A2 ; recupere le nb.
EXCH A1,A2 ; prepare CNTH.
PJRST CNTH
; INTR : EVAL lancements super-rapides.
EV0: ;;; 0SUBR.
JRST (A7) ; ya pas d'argument a evaluer.
EV1: ;;; 1SUBR.
PUSH P,A7 ; sauve l'@ de lancement.
GETCAR A3,A1 ; A1 <- l'arg.
JRST EVAL
EV2: ;;; 2SUBR.
PUSH P,A7 ; sauve l'adresse de lancement.
UNCONS A3,A1,A3 ; A1 <- 1er argument.
JUMPN A3,EV21 ; si el 2eme arg est present.
PUSHJ P,EVAL ; evalue le 1er.
SETZ A2, ; le 2eme est donc NIL.
POPJ P, ; tombe sur l'adresse de lancement.
EV21:
PUSH P,A3 ; sauve le reste.
PUSHJ P,EVAL ; evalue le 1er arg.
EXCH A1,(P) ; (EVAL arg1) <-> [arg2].
PUSHJ P,EVALCA ; evalue le 2eme.
MOVEI A2,(A1) ; A2 <- (EVAL arg1).
POP P,A1 ; A1 <- (EVAL arg2).
POPJ P, ; tombe sur l'adresse de lancement.
EV3: ;;; 3SUBR.
PUSH P,A7 ; sauve l'adresse de lancement.
UNCONS A3,A1,A3 ; A1 <- arg1.
PUSH P,A3 ; sauve le reste.
PUSHJ P,EVAL ; evalue le 1er argument.
EXCH A1,(P) ; (EVAL arg1) <-> [arg2 arg3].
GETCDR A1,A3 ; A3 <- [arg3].
PUSH P,A3 ; on le sauve.
PUSHJ P,EVALCA ; evalue le 2eme argument.
EXCH A1,(P) ; (EVAL arg2) <-> [arg3].
PUSHJ P,EVALCA ; evalue le 3eme argument.
MOVEI A3,(A1) ; A3 <- (EVAL arg3).
POP P,A2 ; A2 <- (EVAL arg2).
POP P,A1 ; A1 <- (EVAL arg1).
POPJ P, ; on doit tomber sur l'@ de lancement.
EVN: ;;; NSUBR.
PUSH P,A7 ; sauve l'adresse de lancement.
; PUSH P,[MACH] ; remember APPEND1 ...
MOVEI A1,(A3) ; recupere les args.
PUSHJ P,EVLIS ; que l'on evalue.
MOVEI A4,(A1) ; les args des NSUBRs sont dans A4.
POPJ P, ; on tombe sur le MACH
; puis seulement sur l'adresse empilee.
EVF: ;;; FSUBR.
MOVEI A1,(A3) ; charge la liste des args dans A1.
JRST (A7) ; et on y va.
EVARR: ;;; ARRAY.
PUSH P,A2 ; sauve le nom du tableau.
GETCAR A3,A1 ; recup l'indice.
PUSHJ P,EVAL ; on l'evalue.
POP P,A2 ; recup le nom du tableau.
EXCH A1,A2 ; pour ELEM.
PUSHJ P,ELEM ; calcul l'adresse de l'element.
MOVE A1,(A5) ; recup l'element.
POPJ P, ; voila.
; INTR : EVAL lancement rapide des lambdas.
; ca fonctionne comme EVLB mais c'est beaucoup plus rapide
ELB0: ;;; 0LAMBDA
GETCDR A7,A1 ; A1 <- ( () body)
GETCDR A1,A1 ; A1 <- BODY.
CAMN A7,-1(P) ; fnt recursive ?
JRST ELT0 ; vers le controle tail.
ELB01: ; c'est vraiment pas tail-recursif.
HRRO A6,P ; prepare la marque de block lambda :
; [ -1 ,, point end frame].
PUSH P,P$BIND ; prepare lambda-frame.
PUSH P,A6 ; force la marque de block lambda.
MOVEM P,P$BIND ; sauve stack point. du old P$BIND.
PUSH P,A7 ; sauve la lambda (pour les tail-rec9.
PJRST LESCAPE
ELT0:
HRRZ A5,(P) ; recup le sommet de pile.
CAIN A5,TAILRC
PJRST EPROGN ; on gagne 5 mots de pile.
JRST ELB01 ; traitement normal.
ELB1: ;;; 1LAMBDA
PUSH P,A7 ; sauve la lambda
GETCAR A3,A1 ; n'evalue qu'1 arg.
PUSHJ P,EVAL ; A1 <- arg evalue.
POP P,A7 ; recupe la lambda.
GETCDR A7,A4 ; A4 <- ((larg) body)
GETCAR A4,A2 ; A2 <- larg.
GETCAR A2,A2 ; A2 <- l'argument.
ELB11:
CAMN A7,-1(P) ; fnt recursive ?
JRST ELT1 ; a voir ...
ELB12: ; c'est vraiment pas tail-rec.
HRRO A8,P ; prepare l marque de frame lambda :
; [ -1 ,, point end frame] .
PUSH P,P$BIND ; prepar lambda-frame.
PUSH P,A2 ; [ 0,,variable ].
GETCAR A2,A6 ; A6 <- old C-val.
HRLM A6,(P) ; [ val ,, var ] (en pile)
PUTCAR A2,A1 ; force new C-val.
PUSH P,A8 ; marque de block lambda .
MOVEM P,P$BIND ; cre le nouveau P$BIND.
PUSH P,A7 ; sauve la lambda (pour les tails-recs)
GETCDR A4,A1 ; A1 <- (body)
PJRST LESCAPE
ELT1:
HRRZ A5,(P) ; recup la derniere adr empilee.
CAIE A5,TAILRC ; on est en tail ?
JRST ELB12 ; non traitement normal.
PUTCAR A2,A1 ; detruit la C-val
GETCDR A2,A1
PJRST EPROGN
ELBL: ;;; L LAMBDA
PUSH P,A7 ; sauve la lambda
GETCAR A3,A1 ;
PUSHJ P,EVLIS ; evalue tous les args.
POP P,A7 ; A7 <- la lambda.
GETCDR A7,A4 ; A4 <- ( arg (body) )
GETCAR A4,A2 ; A2 <- l'argument.
JRST ELB11
; INTR : EVAL evaluations des lambdas-expressions normales.
; sans CONSER !!!
; et en taitant les tail-recs et co-post-recs.
; suppose A2 <- (LAMBDA (...) ...CORPS...)
; A3 <- liste des arguments non evalues.
EVLB::
;;; tests de tail-recursion.
HRRZ A5,(P) ; A5 <- index du sommet de pile.
CAIE A5,TAILRC ; on est en position tail ?
JRST EVLB0 ; non : tout est dit.
CAMN A2,-1(P) ; c'est une fonction recursive ?
JRST EVLBT ; oui: vers traitement rapide.
;;; tests de co-post-recs.
HRRZ A6,P$BIND ; A6 <- index start 1st fame.
HRRZ A6,(A6) ; A6 <- index end 1st frame.
EVCL1:
HRRZ A5,(A6) ; A5 <- adr de retour avant frame.
CAIE A5,TAILRC ; on est encore en position tail ?
JRST EVLB0 ; non : tout est dit.
CAMN A2,-1(A6) ; c'est la meme fonction ?
JRST EVLBT ; c'etait bien co-post-rec.
HRRZ A6,-2(A6) ; A6 <- index fin lambda frame.
CAIE A6,-1 ; y reste des frames en pile ?
JRST EVCL1 ; oui : reprend les tests.
;;; traitement normal des LAMBDAs.
EVLB0:
PUSH P,A2 ; sauve toute la lambda.
HRROS (P) ; marque la LAMBDA [ -1 ,, la lambda].
GETCDR A2,A2 ; A2 <- ((larg) body)
GETCAR A2,A2 ; A2 <- (larg)
;;; 1ere passe : evaluation des args.
JRST EVLB4
EVLB2:
UNCONS A2,A4,A2 ; decons la liste des vars.
PUSH P,A4 ; empile la var suivante.
UNCONS A3,A1,A3 ; decons la liste des args.
JPNIL A1,EVLB3 ; pas la peine d'evaluer NIL.
; ce test est utile car on appelle EVAL
; pour TOUS les args formels,
; y compris les variables locales
; "a la VLISP".
PUSH P,A2 ; sauve le reste des vars.
PUSH P,A3 ; sauve le reste des args.
PUSHJ P,EVAL ; evaluation de l'argument.
POP P,A3 ; recup le reste des args.
POP P,A2 ; recup le reste des vars.
EVLB3:
HRLM A1,(P) ; cre newval ,, var
EVLB4:
JPLIST A2,EVLB2 ; y reste des variables
JPNIL A2,EVLB5 ; c'est bien la fin.
; la liste des vars a la forme ( v v v . v)
PUSH P,A2 ; prepare 0 ,, var
MOVEI A1,(A3)
PUSHJ P,EVLIS ; c'est le seul cas d'appel a EVLIS.
HRLM A1,(P) ; cre newval ,, var
EVLB5: ;;; 2eme passe : liaison proprement dite.
HRRZ A5,P ; A5 <- index dans la pile.
JRST EVLB7
EVLB6:
GETCAR A6,A7 ; A7 <- old C-val
HLLM A6,MEM(A6) ; force la new C-val
HRLM A7,(A5) ; sauve (en pile) la vieille C-val.
SUBI A5,1 ; descends dans la pile.
EVLB7:
MOVE A6,(A5) ; le [new cval ,, var] suivant.
JUMPGE A6,EVLB6 ; c'est pas le marker.
MOVE A1,P$BIND
EXCH A1,(A5) ; empile P$BIND et on recupere
; [ -1 ,, la LAMBDA ].
HLLI A1, ; on demarque : [ 0 ,, la LAMBDA ].
SUBI A5,1 ; ya donc maintenant :
HRLI A5,-1 ; [ -1 ,, point end frame].
PUSH P,A5 ; marque de block lambda.
MOVEM P,P$BIND ; sauve le lien des blocks lambdas.
PUSH P,A1 ; sauve la lambda pour les tails recs.
GETCDR A1,A1 ; A1 <- ((...) ...)
GETCDR A1,A1 ; A1 <- (le corps)
JRST LESCAPE ; traitement normal.
; INTR : EVAL des LAMBDAS tail-recs et co-post-recs.
; suppose A2 <- (LAMBDA (...) ...corps...)
; A3 <- liste des args non-evalues.
EVLBT:
GETCDR A2,A2 ; A2 <- ( (lvar) ... body ...)
UNCONS A2,A2,A4 ; A2 <- (lvar)
PUSH P,A4 ; A4 <- (... body ...)
PUSH P,MRK.MRK ; pour reperer la fin des args.
;;; 1ere passe : evaluation des args.
JRST EVLBT4
EVLBT2:
UNCONS A2,A4,A2 ; decons la liste des vars.
PUSH P,A4 ; empile la var suivante.
UNCONS A3,A1,A3 ; decons la liste des args.
JPNIL A1,EVLBT3 ; pas la peine d'evaluer NIL.
; ce test est utile car on appelle EVAL
; pour TOUS les args formels,
; y compris les variables locales
; "a la VLISP".
PUSH P,A2 ; sauve le reste des vars.
PUSH P,A3 ; sauve le reste des args.
PUSHJ P,EVAL ; evaluation de l'argument.
POP P,A3 ; recup le reste des args.
POP P,A2 ; recup le reste des vars.
EVLBT3:
HRLM A1,(P) ; cre newval ,, var
EVLBT4:
JPLIST A2,EVLBT2 ; y reste des variables
JPNIL A2,EVLBT6 ; c'est bien la fin.
; la liste des vars a la forme ( v v v . v)
PUSH P,A2 ; prepare 0 ,, var
MOVEI A1,(A3)
PUSHJ P,EVLIS ; c'est le seul cas d'appel a EVLIS.
HRLM A1,(P) ; cre newval ,, var
JRST EVLBT6 ; vers le bind sauvage.
;;; 2eme passe : bind sauvage.
EVLBT5:
HLLM A6,MEM(A6) ; effectue le bind sauvage.
EVLBT6:
POP P,A6 ;
JUMPGE A6,EVLBT5 ; c'est pas le marquer.
POP P,A1 ; recup ( ... body ... )
PJRST EPROGN ; c'est plus rapide nan !
; INTR : EVAL fonctions normales et tracees.
EVAL5:: ;;; EVAL normal pour des formes a fonction
; atomique qui ne se lancent pas
; super-rapidement.
GETCDR A2,A4 ; A4 <- P-liste de l'atome fonction.
;;; recherche de l'un des indicateurs :
; EXPR FEXPR MACRO.
EVAL51: ; recherche sur la P-liste de l'atome fonction.
JUMPE A4,EVAL6 ; fin de la P-liste : yavait rien.
UNCONS A4,A5,A6 ; A5 <- indicateur suivant.
CAIN A5,EXPR
JRST EVAL52 ; si EXPR.
CAIN A5,FEXPR
JRST EVAL53 ; si FEXPR.
CAIN A5,MACRO
JRST EVAL54 ; si MACRO.
GETCDR A6,A4 ; avance dans la P-liste
JUMPN A4,EVAL51 ; ca continue.
JRST EVAL6 ; fin P-liste au milieu ?!?
EVAL52: ;;; lancement des EXPRs.
GETCAR A6,A2 ; A2 <- (LAMBDA ... ) .
JRST EVAL21 ; on reteste tout.
EVAL53: ;;; lancement des FEXPRs.
GETCAR A6,A1 ; A1 <- (LAMBDA ... ) fn pour APPLY.
CONSL A4,A3,NIL ; A4 <- LARG.
PJRST APPLY
EVAL54: ;;; lancement des MACROs.
MOVEI A4,(A1) ; larg pour APPLY (toute la forme).
GETCAR A6,A1 ; A1 <- (LAMBDA ... ) sous MACRO.
PUSHJ P,APPLYL ; i fodra conser larg.
JRST EVAL
EVAL6: ;;; recherche de l'un des indicateurs
; speciaux : SUBR FSUBR AUTOLOAD ARRAY.
JNATOM A2,ERUDFE ; y fo un atome litteral.
HLRZ A6,MEM+5(A2) ; A6 <- indicateur special.
HRRZ A7,MEM+5(A2) ; A7 <- adresse de lancement.
CAIN A6,SUBR
JRST EVAL7
CAIN A6,FSUBR
JRST EVAL8
CAIN A6,A.AUTO ; AUTOLOAD ?
JRST EVAL9 ; ouaip.
CAIN A6,ARRAY ; ARRAY ?
JRST EVARR ; ouaip.
;;; ya pas d'indicateurs.
GETCAR A2,A4 ; A4 <- CVAL de fn.
CAIN A4,AESC ; ESCAPE fn ?
JRST ESCAPP ; he oui.
GETCAR A4,A5 ; pour infinite loop EVAL.
CAIE A4,(A5) ; sans perdre le nom de la fonction.
CAIN A2,(A4)
JRST ERUDFE
MOVEI A2,(A4) ; c'est tout bon.
JRST EVAL21 ; indirection sur la C-val.
EVAL7: ;;; lancement des SUBRs.
HLRZ A8,MEM+4(A2) ; recupere les bits speciaux.
TRZE A8,BITRAC ; y fo tracer cette SUBR ?
JRST EVAL78 ; ouaip.
EVAL71:
PUSH P,A7 ; empile l'@ de lancement.
JRST MEVEVL ; vers EVLIS puis MACH.
EVAL78: ; trace d'un SUBR.
TRNN RG,IBIT9 ; trace active ?
JRST EVAL71 ; nan.
PUSH P,A2 ; sauve FN (pour RETRACE).
PUSH P,[RETRAC] ; prepare l'appel de RETRACE.
PUSH P,A7 ; prepare l'@ de lancement.
PUSHJ P,EVEVL ; evalue les args avec EVLIS.
PUSH P,A1 ; sauve FN (pour TRACES).
PUSHJ P,MACH ; on dispatche les arguments.
PUSH P,A4 ; sauve Larg (pour TRACES).
PJRST TRACES ; on y va.
EVAL8: ;;; lancement des FSUBRs.
MOVEI A1,(A3) ; A1 <- la liste des arguments.
HLRZ A8,MEM+4(A2) ; recupere les bits speciaux.
TRZN A8,BITRAC ; y fo tracer cette FSUBR ?
JRST (A7) ; nan : on y va tout de suite.
TRNN RG,IBIT9 ; trace active ?
JRST (A7) ; nan : on y va.
PUSH P,A2 ; FN pour (RETRACE).
PUSH P,[RETRAC] ; prepare l'appel de RETRACE.
PUSH P,A7 ; @ lanc (POUR GO).
PUSH P,A2 ; FN pour TRACES.
PUSH P,A1 ; ARGS (POUR TRACE).
JRST TRACES
EVAL9: ;;; indicateur AUTOLOAD.
SETZM MEM+5(A2) ; il ne sert qu'une fois.
SAVR A2,A3 ; sauve nom fonct, larg.
MOVEI A1,(A7) ; A1 <- filename.
PUSHJ P,LIBRARY+1
BABYL A3,A2
JNNIL A1,EVAL21 ; LIBRARY a bien marche.
JRST ERUDFE ; il a pas marche => ER A9.
; INTR : SUBR FSUBR EVEVL MACH
$$EVAP::
ASUBR:
HLRZ A6,MEM+5(A1)
CAIE A6,SUBR
JRST ERSUBR
HRRZ A7,MEM+5(A1) ; @ LANCEM.
MOVE A3,A2
MOVE A2,A1
JRST EVAL7
AFSUB:
HLRZ A6,MEM+5(A1) ; RECUP INDIC SPEC.
CAIE A6,FSUBR
JRST ERFSUB
HRRZ A7,MEM+5(A1)
MOVE A3,A2
MOVE A2,A1
JRST EVAL8
MEVEVL::
PUSH P,[MACH]
EVEVL: ;** APPEL EVLIS PUIS AIGUILLAGE.
PUSH P,A2 ; sauve la fonction.
MOVEI A1,(A3) ; a1 <- liste argument.
PUSHJ P,EVLIS
MOVEI A4,(A1) ; A4 <- (EVLIS (CDR A1))
POP P,A1 ; restore la fonction.
POPJ P,
MACH: ; distribution des arguments pour SUBRS.
UNCONS A4,A1,A5 ; A1 <- (CAR A4)
UNCONS A5,A2,A5 ; A2 <- (CADR A4)
GETCAR A5,A3 ; A3 <- (CADDR A4)
POPJ P,
; INTR : evaluations speciales LAMBDA COMMENT POUR ETRACE
; (LAMBDA x y ... ) [FSUBR] ramene (LAMBDA x y ... )
ALAMDA:
MOVE A1,LFORME ; car toute les formes sont stockees
POPJ P, ; dans Last FORME.
; (COMMENT ... ) [FSUBR]
ACMMFN:
MOVEI A1,ACOMFN ; pour ramener COMMENT.
POPJ P,
; (POUR EVAL ... ) [FSUBR]
POUR:
UNCONS A1,A2,A1 ; isole le 1er arg
CAIN A2,A.EVAL ; c'est l'atome EVAL ?
PJRST EPROGN ; oui : on effectue le PROGN.
PJRST FALSE ; non : on ramene NIL.
; (ETRACE <s>) [1SUBR] EPROGN <s> avec le bit de trace EVAL.
ETRACE:
MOVN A5,RG ; sauve le R.G. courant.
PUSH P,A5 ; a cause des G.C.
SETBIT IBIT3 ; force le bit trace eval.
PUSHJ P,EPROGN ; EPROGN l'argument.
POP P,A5 ; restaure le R.G.
MOVN RG,A5
POPJ P, ; ramene le EPROGN evalue.
; INTR : EVLIS
; (EVLIS e) [1SUBR]
EVLIS::
JPNIL A1,VPOPJ ; NIL is NIL.
GETCDR A1,A2 ; sauve le CDR de
PUSH P,A2 ; la liste.
PUSHJ P,EVALCA ; evalue le 1er element.
CONSL A1,A1,NIL ; on en fait le debut de la liste result.
POP P,A2 ; recup le reste de la liste.
JNLIST A2,VPOPJ ; La liste n'avait qu'un element.
PUSH P,A1 ; ce sera la valeur ramene.
PUSH P,A1 ; ce sera le pointeur courant sur le result.
PUSH P,A2 ; empile aussi la liste des elements.
MOVEI A1,(A2)
EVLIS1:
GETCDR A1,A2 ; sauve le reste des elements
MOVEM A2,(P) ; dans la pile (sans PUSH car c'est un peu long)
PUSHJ P,EVALCA ; evalue l'element.
CONSL A1,A1,NIL ; on en cre une liste.
MOVE A2,-1(P) ; recup le pointeur courant.
PUTCDR A2,A1 ; on accroche le nouvel element.
MOVEM A1,-1(P) ; actualise courant.
MOVE A1,(P) ; recupere le reste des lements.
JPLIST A1,EVLIS1 ; il en reste.
SUB P,[3,,3] ; restaure la pile.
MOVE A1,1(P) ; ramene la liste cree.
POPJ P,
; INTR : EPROGN PROGN PROG1 PROG2
; (EPROGN l) [1SUBR]
; (PROGN e1 ... eN) [FSUBR]
EPROGD::
GETCDR A1,A1
JUMPN A1,EPROGN ; ya quekchose a faire.
POPJ P, ; yavait rien => NIL.
PROGN1:
PUSH P,A2 ; sauve le CDR.
PUSHJ P,EVALCA ; evalue le CAR
POP P,A1 ; recupere le reste.
EPROGN:
GETCDR A1,A2 ; A2 <- le rste.
JUMPN A2,PROGN1 ; yen a au - 2 encore.
PJRST EVALCA ; le dernier doit etre appelle avec
; un JRST pour traiter correctement
; les TAILS-RECURSIVES.
; (PROG2 ... ) [FSUBR]
; (PROG1 ... ) [FSUBR] et non NSUBR comma ca ya pas de CONS.
PROG2:
JNLIST A1,VPOPJ ; ya rien a faire.
UNCONS A1,A1,A2 ; A1 <- le 1er element
PUSH P,A2 ; on sauve le reste
PUSHJ P,EVAL ; evalue le 1er
POP P,A1 ; PROG1 doit suivre .....
PROG1:
JNLIST A1,VPOPJ ; y rien a faire.
UNCONS A1,A1,A2 ; A1 <- le 1er element.
PUSH P,A2 ; sauve le reste.
PUSHJ P,EVAL ; evalue le 1er element.
EXCH A1,(P) ; dont la valeur est echangee avec le reste.
PUSHJ P,EPROGN ; evalue le reste normalement
POP P,A1 ; valeur ramenee par PROGx.
POPJ P, ; voila
SUBTTL FONCTIONS DE CONTROLE
$$CTRL::
PRINTX /8-CTRL.FUNCT/
; (LESCAPE S1 ... SN) [FSUBR] sort de la lambda-expr courante.
LESCAPE:
PUSHJ P,EPROGN ; evalue la valeur de la LAMBDA.
TAILRC: ; cette adresse est utilisee par APPLY0
; pour traiter les tails-recursives.
MOVE A5,P$BIND ; recup le pointeur des BINDs.
AOJGE A5,ERLESC ; yavait pas de lambdas precedentes.
SUBI A5,1 ; repositonne P$BIND.
JSP L,UNBINP ; RESTAURE LES VARIABLES.
POPJ P, ; ON SORT DU LAMBDA.
JRST ERLESC ; C'ETAIT UN BLOC ESCAPE.
JRST ERLESC ; UN BLOCK PROG.
JRST ERLESC ; UN BLOCK DO.
HALT REENTE ; BREAK.
; (ESCAPE NOM S1 ... SN ) - FSUBR -
ESCAPE:
GETCAR A1,A2 ; A2 <- NOM D U ESCAPE.
PUSH P,A2 ; P$NAME.
MOVEI A4,AESC ; NEW CVAL.
MOVSI A7,-2 ; TYPE BLOCK = ESCAPE (i.e. MRK.ESC).
JSP L,BIND
ESCAPP:
PUSH P,A2 ; SAUVE LE NOM
PUSHJ P,EPROGD ; EVALUE SA VALEUR DE RETOUR.
POP P,A2 ; RECUP LE NOM.
ESCAPT::
MOVE A5,P$BIND ; recupere le pointeur des BINDs.
AOJGE A5,ERESCP ; y encore des frames ? non : erreur.
SUBI A5,1 ; repositionne P$BIND.
JSP L,UNBINP
JRST ESCAPT ; CONTINUE A DEPILER SI LAAMBDA.
JRST [ CAMN A2,P$NAME ; C'EST LE BON ESCAPE ?
POPJ P, ; OUI.
JRST ESCAPT] ; NON : CONTINUE AA DEPILER.
JRST ESCAPT ; CONTINUE A DEPILER SI PROG.
JRST ESCAPT ; CONTINUE A DEPILER DI DO.
HALT REENTE ; BREAK.
; CTRL : OR AND IF IFN
; (OR S1 ... SN) [FSUBR] [ARG DS A1]
; (AND S1 ... SN) [FSUBR] [ARG DS A1]
; prevu pour traiter les tails-recursives.
OR1:
PUSH P,A2 ; sauve le reste.
PUSHJ P,EVALCA ; evalue l'element.
JNNIL A1,P.P ; ca a ramene non NIL.
POP P,A1 ; recupere le reste.
OR:
GETCDR A1,A2 ; avance dans la liste.
JNNIL A2,OR1 ; c'est pas une tail.
JRST EVALCA ; tail rec hack !
AND: JNNIL A1,AND2 ; au boulot !
PJRST TRUTH ; (AND) => T.
AND1:
PUSH P,A2 ; sauve le reste.
PUSHJ P,EVALCA ; evalue l'element.@
JPNIL A1,P.P ; ca a ramene NIL.
POP P,A1 ; recupere le reste.
AND2:
GETCDR A1,A2 ; avance dans la liste.
JNNIL A2,AND1 ; c'set pas une TAIL.
JRST EVALCA ; tail rec hack !
; (IF TEST THEN ELSE) - FSUBR -
IFF:
PUSH P,A1
PUSHJ P,EVALCA
MOVEI A2,(A1)
POP P,A1
GETCDR A1,A1
JUMPN A2,EVALCA ; THEN
JRST EPROGD ; ELSE
; (IFN TEST THEN ELSE ... )
IFFN:
PUSH P,A1 ; SAUVE LE TOUT.
PUSHJ P,EVALCA ; EVALUE TEST.
MOVEI A2,(A1)
POP P,A1
GETCDR A1,A1 ; A1 <- (THEN ELSE ... )
JPNIL A2,EVALCA ; THEN
PJRST EPROGD ; ELSE.
; CTRL : COND SELECT
; (COND (E1 S1 ... SN) ... (EN U1 ... UN)) - FSUBR - \ARG DS A1]
COND1:
GETCDR A2,A1 ; ON CONTINUE.
JUMPE A1,VPOPJ ; OLD *ER A3.
COND: ;** ENTRY
PUSH P,A1 ; SAUVE LA LISTE.
GETCAR A1,A1 ; A1:= UNE CLAUSE.
JNLIST A1,P.P ; CLAUSE ATOMIQUE.
PUSHJ P,EVALCA ; A1:=(EVAL (CAR CLAUEE)).
POP P,A2 ; REST REST.
JUMPE A1,COND1 ; SI TEST FAILED, VERS COND1.
COND2:
GETCAR A2,A3 ; A3:= LA CLAUSE A FAIRE.
GETCDR A3,A2 ; A2 L'ACTION.
JUMPE A2,VPOPJ ; YA RIEN A FAIRE.
MOVE A1,A2 ; PREPARE EPROGN.
JRST EPROGN
; (SELECT A S1 ... SN FAILED) - FSUBR -
SELECT:
GETCDR A1,A2
PUSH P,A2 ; SAUVE L
PUSHJ P,EVALCA
POP P,A3
EXCH A1,A3
SELEC1:
PUSH P,A1 ; SAUVE L
PUSH P,A3 ; SAUVE A
GETCAR A1,A1
PUSHJ P,EVALCA
POP P,A3 ; REST A
POP P,A2 ; REST L
CAMN A1,A3
JRST COND2 ; C'EST CUI-LA
GETCDR A2,A1
GETCDR A1,A3
JUMPN A3,SELEC1 ; C'EST PAS LA DERNIERE
GETCAR A1,A1 ; C'EST LE CAILED.
JRST EPROGN
; CTRL : SELECTQ
; (SELECTQ A S1 ... SN FAILED) - FSUBR -
; Ce SELECTQ est generalise : il utilise EQ ou MEMBER!
SELEQ:
GETCDR A1,A2
PUSH P,A2 ; SAUVE (S1 ... SN F).
PUSHJ P,EVALCA
CAMGE A1,BCNUM ; litatom ou inumb ?
JRST SELEQ5 ; oui : vers taitement rapide.
;;; SELECTQ lent (avec EQ et MEMBER).
EXCH A1,(P)
PUSH P,A1 ; SAUVE VAL DE A.
SELEQ1:
POP P,A2
GETCDR A2,A3
JUMPN A3,SELEQ2 ; SI NIL VERS FAILED
POP P,A1 ; DEPILE A.
GETCAR A2,A1
JRST EPROGN ; CLAUSE FAILED.
SELEQ2:
PUSH P,A3
GETCAR A2,A3 ; SN.
PUSH P,A3 ; SAUVE SN.
GETCAR A3,A2 ; RECUP TEST.
MOVE A1,-2(P) ; A1 <- A.
SKLIST A2
SKIPA A6,[EQ]
MOVEI A6,MEMBER
PUSHJ P,(A6)
POP P,A2 ; A2 <- S.
JUMPE A1,SELEQ1 ; CA A APS MARCHE.
POP P,A1 ; A1 <- (S ... S).
POP P,A1 ; A1 <- A.
GETCDR A2,A3
JUMPE A3,VPOPJ ; YA RIEN A AFIRE (RAMENE A).
MOVE A1,A3
JRST EPROGN
SELEQ5: ;;; SELECTQ rapide (avec EQP).
POP P,A2 ; recup les clauses.
SELEQ6:
UNCONS A2,A3,A2 ; A3 <- clause suivante.
JPNIL A2,SELEQ8 ; c'est la clause failed.
GETCAR A3,A4 ; A4 <- le selecteur.
JPLIST A4,SELEQ9 ; y fo faire un MEMQ.
CAIE A1,(A4) ; C'est le bon ?
JRST SELEQ6 ; nan.
SELEQ7: ; la clause A3 est selectee.
GETCDR A3,A3 ; A3 <- le PROGN a faire.
JPNIL A3,VPOPJ ; mais c'est vide (ramene A1).
SELEQ8:
MOVEI A1,(A3) ; prepare A1.
JRST EPROGN
SELEQ9: ; MEMQ open.
UNCONS A4,A5,A4 ; A5 <- atome suivant.
CAIN A1,(A5) ; c'est cui-la ?
JRST SELEQ7 ; ouaip.
JNNIL A4,SELEQ9 ; yen a encore.
JRST SELEQ6 ; c'est fini : clause suivante.
; CTRL : WHILE UNTIL REPEAT
; (WHILE E S1 ... SN) [FSUBR] [ARG DS A1]
; (UNTIL E S1 ... SN) == (WHILE (NOT E) S1 ... SN)
; pas tail-recursif evidement
UNTIL:
PUSH P,[JUMPE A1,WHIL1]
JRST WHIL0
WHILE:
PUSH P,[JUMPN A1,WHIL1]
WHIL0:
UNCONS A1,A2,A1
PUSH P,A1 ; empile le corps
PUSH P,A2 ; empile le test
JRST WHIL2 ; et c'est parti.
WHIL1:
MOVE A1,-1(P) ; recupere le coRPS
PUSHJ P,EPROGN
WHIL2:
MOVE A1,(P) ; recupere le test.
PUSHJ P,EVAL
XCT -2(P) ; JUMPE/JUMPN A1,WHIL1
JRST PPP.P ; vide la pile et rentre.
; (REPEAT n s1 ... s2) [FSUBR]
; ramene la derniere evaluation du PROGN.
REPEAT:
GETCDR A1,A2
PUSH P,A2 ; sauve (S1 ... SN) .
PUSHJ P,EVALCA ; evalue le nombre.
MOVN A5,MEM(A1) ; recup -N .
PUSH P,A5 ; sauve -N (a cause des G.C.)
SETZ A1, ; au cas ou on ferait rien.
JRST REPEA2
REPEA1:
MOVE A1,-1(P) ; recup le PROGN a faire.
PUSHJ P,EPROGN ; on l'execute.
REPEA2:
AOSG (P) ; on decompte (en negatif).
JRST REPEA1 ; il en fo encore.
JRST PP.P ; c'est fini.
SUBTTL FONCTIONNELLES
$$FNCT::
; (MAP L FN) [2SUBR] [L -> A1 ; FN -> A2]
; (MAPC L FN) [2SUBR]
; y fo reecrire ce code car tout appel de APPLY est
; VRAIMENT DEBILE : y fo en realite ne determiner
; qu'une seule fois le type de la fonction.
MAP:
PUSH P,[MOVE A4,A1]
JRST MAP0
MAPC:
PUSH P,[HLRZ A4,MEM(A1)] ; GETCAR A1,A4.
MAP0:
PUSH P,A2 ; sauve la fonction.
PUSH P,A1 ; sauve la liste des arguments.
JRST MAP2
MAP1:
XCT -2(P) ; prepare A4 (arguments pour APPLY).
GETCDR A1,A1 ; avance dans les arguments.
MOVEM A1,(P) ; sauve le reste.
MOVE A1,-1(P) ; recupla fonction.
PUSHJ P,APPLYL ; (APPLY fonction (LIST arg)).
MOVE A1,(P) ; restore la liste des arguments restants.
MAP2:
JPLIST A1,MAP1 ; c'est pas fini.
PJRST PPP.P ; on depile et on rentre.
; FNCT : MAPLIST MAPCAR MAPT MAPCT
; (MAPLIST L FN) - SUBR - [L -> A1 ; FN -> A2]
; (MAPCAR L FN) - SUBR -
; (MAPT L FN) - SUBR -
; (MAPCT L FN) - SUBR -
MAPT:
PUSH P,[MOVE A4,A1]
JRST MAPT0
MAPCT:
PUSH P,[HLRZ A4,MEM(A1)]
MAPT0:
PUSH P,[JUMPE A1,MAPL3]
JRST MAPL00
MAPLIST:
PUSH P,[MOVE A4,A1]
JRST MAPL0
MAPCAR:
PUSH P,[HLRZ A4,MEM(A1)] ; GETCAR A1,A4.
MAPL0: ;;; INIT PILE.
PUSH P,[JUMP]
MAPL00:
PUSH P,A2 ; SANE FN.
CONSL A2,NIL,NIL ; PREPARE LISTE RESULTAT.
PUSH P,A2 ; SAUVE LIST RESULT.
PUSH P,A2 ; SAUVE LAST.
PUSH P,A1 ; SAUVE L.
JRST MAPL3
MAPL1: ;;; APPLE APPLY.
XCT -4(P) ; PREP A4 (ARG POUR APPLY).
GETCDR A1,A1
PUSH P,A1 ; SAUVE LE RESTE.
MOVE A1,-3(P) ; RECUP FN.
PUSHJ P,APPLYL
;;; CONS LISTE RESULTAT.
XCT -4(P) ; TEST DU SUBSET OU NO-OP.
CONSL A1,A1,NIL ; A1 <- (LIST A1)
MOVE A2,-1(P) ; RECUP LAST.
ADLIST A2,A1 ; FORME LA LISTE RESULTAT.
MOVEM A2,-1(P) ; SAUVE LAST.
MAPL3: ;;; AU SUIVANT.
POP P,A1 ; REST L.
JPLIST A1,MAPL1 ; YEN A ENCORE.
POP P,A1 ; REST LAST
POP P,A1 ; REST LISTE RESULT.
GETCDR A1,A1
PJRST PPP.P
; FNCT : MAPS MAPSUB MAPST
; M A P S O U S - S T R U C T U R E S
;
; (MAPS L FN) - SUBR - [L -> A1 ; FN -> A2]
; (MAPSUB L FN) - SUBR -
; (MAPST L FN) - SUBR -
MAPST:
SKIPA A6,[JUMPE A1,MAPS5] ; CONS RES SI # NIL.
MAPSUB:
MOVE A6,[JUMP A1,MAPS5] ; CONS RES TOUJOURS.
JRST MAPS1
MAPS:
MOVE A6,[JUMPA A1,MAPS5] ; CONS RES JAMAIS.
MAPS1:
MOVEI A4,(A1) ; A4 <- L.
MOVEI A1,(A2) ; A1 <- FN.
CONSL A2,NIL,NIL ; PREPARE LISTE RESULTAT.
PUSH P,A2 ; LISTE RESULTAT.
PUSH P,[PD.P] ; PREP RETOUR NORMAL.
MAPS3:
PUSH P,A1 ; FN.
PUSH P,A4 ; L.
PUSH P,A6 ; XCT.
PUSH P,A2 ; LAST.
PUSHJ P,APPLYL
POP P,A2 ; REST LAST.
POP P,A6 ; REST XCT.
XCT A6
; CONS LIT RESUL.
CONSL A1,A1,NIL ; A1 <- (LIST A1).
ADLIST A2,A1
MAPS5:
POP P,A4 ; REST L.
POP P,A1 ; REST FN.
SKLIST A4
POPJ P, ; OUI.
UNCONS A4,A4,A3
PUSH P,A3 ; EMPILE LEE CDR.
PUSHJ P,MAPS3
POP P,A4 ; REST CDR.
JUMPN A4,MAPS3
POPJ P,
; FNCT : EVERY SOME ANDF ORF
; (EVERY L FN) - SUBR -
; (SOME L FN) - SUNR -
; PILE: //XCT/FN/CDR L
EVERY:
PUSH P,[JUMPE A1,PP.P]
JRST SOM1
SOME:
PUSH P,[JUMPN A1,PP.P]
SOM1:
PUSH P,A2 ; SAUVE FN.
MOVEI A2,(A1)
JRST SOM3
SOM2:
UNCONS A2,A4,A3
PUSH P,A3 ; SAUVE LE CDR.
MOVE A1,-1(P) ; RECUP FN.
PUSHJ P,APPLYL
POP P,A2
XCT -1(P) ; TEST RETOUR.
SOM3:
JPLIST A2,SOM2 ; YEN A ENCORE.
PJRST PP.P
; (ANDF A F1 ... FN) - NSUBR -
; (ORF A F1 ... FN)
ORF:
PUSH P,[JUMPE A1,ANDF2]
JRST ANDF1
ANDF:
PUSH P,[JUMPN A1,ANDF2]
ANDF1:
GETCAR A1,A1
PUSH P,A1 ; SAUVE ARG.
PUSH P,A4 ; SAUVE TOUT.
JRST ANDF3
ANDF2:
GETCDR A2,A2
JPNIL A2,PP.P
PUSH P,A2
GETCAR A2,A1
MOVE A4,-1(P)
PUSHJ P,APPLYL
ANDF3:
POP P,A2
XCT -1(P)
PJRST PP.P
SUBTTL PROG + DO FEATURE
$$PRDO::
; PROG + DO FEATURES
PROG:
PUSH P,P$LABEL ; SAUVE LE PINTEUR COURANT.
PUSH P,[A.PROG] ; SAUVE LE NOM PROG.
UNCONS A1,A2,A1 ; A2 <- (LVAR).
;;; LIAISON DES LOCALES.
SETZ A4,
MOVSI A7,-3 ; TYPE BLOC = PROG (i.e. MRK.PRG).
JSP L,BIND
MOVEI A5,RETURN ; CE QUI FAUT FAIRE EN FIN.
TLABEL: ; SECTION COMMUNE A PROG ET DO.
PUSH P,MRK.MRK ; MARK TABLE D'ETIQUETTES.
MOVE A2,A1
JRST TLAB2
TLAB1:
UNCONS A1,A3,A1
JPLIST A3,TLAB2
PUSH P,A1
HRLM A3,(P) ; [ LABEL ,, VAL ]
TLAB2:
JPLIST A1,TLAB1
MOVEM P,P$LABEL ; SAUVE POINTEUR TABLE ETIQUETTE.
PUSH P,A5 ; RETURN OU CYCLE EN FIN DE BODY.
XBODY:
JPNIL A2,VPOPJ ; VERS RETURN OU CYCLE.
XBOD1:
UNCONS A2,A1,A2
PUSH P,A2
SKATOM A1 ; SI ETIQUETTE.
PUSHJ P,EVAL
POP P,A2
JNNIL A2,XBOD1
POPJ P, ; RETURN OU CYCLE,
; PROG : DO
DO:
PUSH P,A1
GETCAR A1,A1
CONSL A2,NIL,NIL ; LISTE DES VARIABLES.
PUSH P,A2
CONSL A3,NIL,NIL ; LISTE DES REP.
PUSH P,A3
CONSL A4,NIL,NIL ; LISTE DES INIT.
PUSH P,A4
JRST DO13
DO11:
UNCONS A1,A5,A1 ; A5 <- (VAR INT REP)
UNCONS A5,A6,A5 ; A6 <- VAR
CONSL A6,A6,NIL ; A6 <- (VAR)
ADLIST A2,A6
UNCONS A5,A7,A5 ; A7 <- INIT
CONSL A7,A7,NIL ; A7 <- (INIT)
ADLIST A4,A7
GETCAR A5,A5
JPNIL A5,DO12
CONSL A6,A5,NIL
DO12:
ADLIST A3,A6 ; (VAR) OU (REP)
DO13:
JNNIL A1,DO11
POP P,A1 ; A1 <- init liste.
PUSHJ P,EVLIS ; qu'il faut evaluer.
MOVEI A4,(A1) ; elle finit dans A4.
GETCDR A4,A4 ; A4 <- INIT LISTE.
POP P,A3
GETCDR A3,A3 ; A3 <- REP LISTE.
POP P,A2
GETCDR A2,A2 ; A2 <- VAR LISTE.
POP P,A1
PUSH P,P$DO ; PREPARE LE BLOCK DO
PUSH P,P$LABEL
PUSH P,[A.DO]
MOVSI A7,-4 ; TYPE BLOCK DO (i.e. MRK.DO).
JSP L,BIND
PUSH P,A2 ; VAR LISTE.
PUSH P,A3 ; REP LISTE
GETCDR A1,A1 ; A1 <- ((TEST RET ... ) BODY)
PUSH P,A1 ; ON SAUVE TOUT CA.
MOVEM P,P$DO
GETCDR A1,A1 ; A1 <- BODY POUR TLABEL.
MOVEI A5,CYCLE
JRST TLABEL
; PROG : RETURN CYCLE
RETURN:
MOVE A5,P$BIND ; recupere le pointeur des BINDs.
AOJGE A5,ERRT ; ya pu de frame : erreur.
SUBI A5,1 ; repositionne P$BIND.
JSP L,UNBINP ; depile un nouveau frame.
;;; retours de UNBIND :
JRST RETURN ; LAMBDA/GAMMA
JRST RETURN ; ESCAPE
POPJ P, ; PROG
POPJ P, ; DO
HALT REENTE ; BREAK.
CYCLE:
MOVE A5,P$BIND ; recupere le pointeur des BINDs.
AOJGE A5,ERCYCL ; ya pu de frame : erreur.
SUBI A5,1 ; repositionne P$BIND.
HLRZ A6,(A5) ; recupere juste le typ du block.
CAIN A6,-4
JRST CYCL1 ; C'EST UN BLOCK DO AU POIL.
JSP L,UNBINP
JRST CYCLE
JRST CYCLE
JRST CYCLE
HALT REENTE ; FAUT SAVOIR BORDEL !!
HALT REENTE
CYCL1:
SKIPN A5,P$DO
JRST ERCYCL
MOVE A1,(A5)
GETCAR A1,A1 ; C'EST LE TEST.
JPATOM A1,CYCL2 ; YEN A PAS !!
PUSHJ P,EVALCA
JNNIL A1,CYCL2
MOVE A5,P$DO ; REPOSITIONNE P$DO.
MOVE A1,-1(A5) ; RECUP LISTE REP.
PUSHJ P,EVLIS
MOVE A4,A1
MOVE A5,P$DO
MOVE A2,-2(A5)
JSP L,DBIND
MOVE A5,P$DO ; REPOSITIONNE P$DO.
MOVE A2,(A5) ; ((TEST RET ... ) BODY )
GETCDR A2,A2 ; (BODY)
PUSH P,[CYCLE]
JRST XBODY
CYCL2:
MOVE A5,P$DO
MOVE A1,(A5)
GETCAR A1,A1 ; A1 <- (TEST REP ... )
PUSHJ P,EPROGD
JRST RETURN
; PROG : GO GOTO
GO:
GETCAR A1,A1
GOTO:
MOVE A2,A1
GOTOR:
MOVE A5,P$BIND ; recupere le pointeur des BINDs.
AOJGE A5,ERGOTO ; y apu de frame : erreur.
SUBI A5,1 ; repositionne P$BIND.
HLRZ A6,(A5) ; recupere juste le type du BLOCK.
CAIE A6,-3
CAIN A6,-4
JRST GOTO1
GOTOD:
JSP L,UNBINP
JRST GOTOR
JRST GOTOR
JRST GOTOR
JRST GOTOR
HALT REENTE
GOTO1:
HRRZ A4,P$LABEL
JRST GOTO3
GOTO2:
PUSH P,A2
PUSHJ P,EQ
POP P,A2
JNNIL A1,GOTO4
SUBI A4,1
GOTO3:
HLRZ A1,(A4)
JUMPGE A1,GOTO2
GOTO4:
HRRZ A2,(A4)
MOVE P,P$LABEL
ADD P,[1,,1] ; pour compenser le corps empile.
JRST XBODY
SUBTTL PREDICATS
$$PRED::
PRINTX /9-PRED.BASE,P-LISTE-DEF/
ATOM: ; T si A1 est un atome
SNLIST A1 ; i.e LITATOM NIMBP STRINGP
TDZA A1,A1 ; NIL
MOVEI A1,T ; T
POPJ P,
LITATO: ; T si A1 est un LITATOM.
SKATOM A1 ; i.e. just LITATOM.
TDZA A1,A1 ; NIL
MOVEI A1,T ; T
POPJ P,
NOT: ; NOT identique a NULL.
NULL:
JUMPE A1,TRUTH
JRST FALSE
LISTP: ; T si A1 est une liste.
SKLIST A1
TDZA A1,A1
MOVEI A1,T
POPJ P,
EQP: ; teste les 2 pointeurs A1 et A2.
CAIE A1,(A2) ; (plus rapide que CAME A1,A2).
TDZA A1,A1 ; A1 <- NIL
MOVEI A1,T ; A1 <- T
POPJ P,
NEQP: ; le contraire de EQP.
CAIN A1,(A2)
TDZA A1,A1
MOVEI A1,T
POPJ P,
BOUNDP: ; T si l'atome A1 a une valeur # UNDEF.
JNATOM A1,TRUTH ; si c'est pas un LITATOM => T.
GETCAR A1,A1 ; recup la C-val de A1.
CAIN A1,UNDEF ; c'est 'UNDEF' ?
TDZA A1,A1 ; oui : A1 <- NIL.
MOVEI A1,T ; nan.
POPJ P,
; PRED : EQ NEQ
; (EQ AT1 AT2) [2SUBR] teste 2 atomes.
; (NEQ AT1 AT2) == (NOT (EQ AT1 AT2))
; ne touche pas a A2 qu'on se le dise.!
NEQ:
PUSH P,[NOT]
EQ: ;;; cas LITATOM.
CAIN A1,(A2) ; si EQP alors EQ !!!
PJRST TRUTH ; (petite optimisation).
CAMGE A1,BCNUM ; EQP dit suffire pour
JRST FALSE ; les litatoms et les inumbs.
EQ1: ;;; cas nombre cree.
CAML A1,BSTRG
JRST EQ2
JNNUMB A2,FALSE ; si type # => faux.
MOVE A5,MEM(A1) ; recup 1ere valeur.
CAME A5,MEM(A2) ; test.
TDZA A1,A1 ; A1 <- NIL.
MOVEI A1,T ; A1 <- T
POPJ P, ; VOILA.
EQ2: ;;; cas chaine.
JPLIST A1,FALSE ; EQP aurait du suffire pour des LISTEs.
JNSTRG A2,FALSE ; si type # => faux.
GETCDR A1,A5 ; recup liste des caracteres de A1.
GETCDR A2,A6 ; idem pour A2.
EQ21:
JUMPE A5,EQ25 ; fin chaine.
UNCONS A5,A7,A5 ; avance chaine 1
UNCONS A6,A8,A6 ; avance chaine 2
CAIN A7,(A8) ; test.
JRST EQ21 ; y sont egaux.
SETZ A1, ; y sont differents
POPJ P,
EQ25:
JUMPN A6,FALSE ; l'autre chaine n'est pas finie.
POPJ P, ; la c'est tout bon.
; PRED : EQUAL NEQUAL
; (EQUAL S1 S2) [2SUBR] MODIFIE
; (NEQUAL S1 S2)
;
; (DE EQUAL (A1 A2)
; (COND
; ((ATOM A1) (EQ A1 A2))
; ((ATOM A2) NIL)
; ((EQUAL (NEXTL A1) (NEXTL A2))
; (EQUAL A1 A2)) ))
NEQUAL:
PUSH P,[NOT] ; POUR RETOUR NEQUAL.
EQUAL:
MOVEM P,TEMP$P ; SAUVE POINTEUR DE PILE.
JRST EQUAL2
EQUAL1:
UNCONS A1,A1,A3
UNCONS A2,A2,A4
SAVR A3,A4 ; SAUVE (CDR A1) ET (CDR A2)
PUSHJ P,EQUAL2 ; RECURSE SUR LES CARS.
BABYL A2,A3 ; RESTORE LES 2
JPNIL A1,EQUAL3 ; EQ A RAMENE FAUX.
MOVEI A1,(A3) ; RESTITUE LE RESTE.
EQUAL2:
JNLIST A1,EQ ; LE EQ EST SUFFISANT.
JPLIST A2,EQUAL1 ; ITERATION SUR LES CDRS.
EQUAL3:
MOVE P,TEMP$P ; RESTITUE LA PILE.
JRST FALSE ; ET C'EST FAUX (SORTIE RAPIDE).
; PRED : SORT SAMEPN
; (SORT A1 A2) [2SUBR]
; RAMENE T SI LE PNAME DE A1 EST <= AU PNAME DE A2 (TRI ALPHA)
; IL FAUT TRAITER CARACTERE/CARACTERE A CAUSE DU NB DE CARACT EN TETE.
SORT:
MOVE A5,[POINT 7,MEM+1(A1),6]
MOVE A6,[POINT 7,MEM+1(A2),6]
SORT1:
ILDB A7,A5 ; CARACTERE SUIVANT DE A1.
ILDB A8,A6 ; CARACTERE SUIVANT DE A2.
CAIN A7,(A8)
JUMPN A7,SORT1 ; Y SONT EGAUX (ET NON NULLS) !
CAILE A7,(A8) ; SORT PROPREMENT DIT.
TDZA A1,A1 ; A1 <- NIL.
MOVEI A1,T ; A1 <- T.
POPJ P, ; VOILA
; (SAMEPN A1 A2) [2SUBR]
; RAMENE T SI LE PNAME DE A1 COMMENCE PAR LE PNAM DE A2
SAMEPN:
MOVE A5,[POINT 7,MEM+1(A1),6]
MOVE A6,[POINT 7,MEM+1(A2),6]
SAMEP1:
ILDB A8,A6 ; CARACTERE SUIVANT DE A2.
JUMPE A8,TRUTH ; FIN DE A2 => T.
ILDB A7,A5 ; CARACTERE SUIVANT DE A1.
CAIN A7,(A8)
JRST SAMEP1 ; Y SONT ENCORE EGAUX.
SETZ A1, ; NIL -> A1.
POPJ P,
SUBTTL FONCTIONS SUR LES P-LISTES
$$PLIS::
; SI PL EST UN ATOME LA P-LISTE EST CELLE DE CET ATOME,
; sinon la P-liste est PL.
; si PL est un nombre ou une chaine, toutes les fonctions
; ramenent NIL.
; les indicateurs IND peuvent etre de n'importe quel type.
; (ADDPROP PL PVAL IND) [3SUBR]
; empile la propriete PVAL sous l'indicateur IND dans la P-liste PL.
ADDPROP:
JPLIST A1,ADDPR1 ; on peut y aller tout de suite.
JNATOM A1,FALSE ; si nombre ou chaine.
; sont-ce des indicateurs speciaux ?
CAIN A3,EXPR ; y fo dans ce cas-la detruire
HRRZS MEM+4(A1) ; les bits speciaux.
CAIN A3,FEXPR ; la pareil.
HRRZS MEM+4(A1)
CAIN A3,MACRO ; la egalement.
HRRZS MEM+4(A1)
ADDPR1:
MOVEI A4,(A1) ; sauve PL.
SKLIST A4 ; si PL est un atome,
GETCDR A4,A4 ; on prend sa P=LISTE.
CONSL A4,A2, ; rajoute la PVAL,
CONSL A4,A3, ; rajoute l'IND.
SNLIST A1 ; si PL est une liste,
SKIPA A1,A4 ; on la ramene inchangee,
PUTCDR A1,A4 ; sinon on change le CDR de l'atome.
POPJ P, ; Voila !
; P-L- : PUT ;
; (PUT PL PVAL IND) [3SUBR]
; change la proriete de l'indicateur IND, dans la P-liste PL.
PUT:
JPATOM A1,PUT0 ; si PL est une liste.
JNLIST A1,FALSE ; en cas de nombre ou chaine.
PUT0:
MOVEI A4,(A1) ; sauve PL.
CAML A3,BCNUM ; si IND n'est pas litatom ou inumb
JRST PUT3 ; vers PUT lent (avec EQUAL).
;;; PUT rapide avec EQP.
SKLIST A4 ; si PL est un atome,
; on prend son CDR.
PUT1:
GETCDR A4,A4 ; avance sur la P-liste.
JNLIST A4,ADDPROP ; fin PL : on cre l'indicateur.
GETCAR A4,A5 ; A5 = l'indic.
CAIN A5,(A3) ; meme indic ?
JRST PUT2 ; ouaip.
GETCDR A4,A4 ; on avance.
JPLIST A4,PUT1 ; la P-LISTE continue.
JRST ADDPROP ; fin P-L au milieu !?!
PUT2: ; j'ai trouve l'indicateur.
GETCDR A4,A4
PUTCAR A4,A2 ; set new P-val.
POPJ P,
PUT3: ;;; PUT lent avec EQUAL.
PUSH P,A1 ; sauve PL.
PUSH P,A2 ; sauve P-val.
PUSH P,A3 ; sauve IND.
SKLIST A4 ; si PL est un atome,
; on prend son CDR.
PUT4:
GETCDR A4,A4 ; avance en P-liste.
JNLIST A4,PUT5 ; fin P-liste.
PUSH P,A4 ; sauve le reste.
GETCAR A4,A1 ; prend l'indicateur suivant.
MOVE A2,-1(P) ; recup IND.
PUSHJ P,EQUAL
POP P,A4 ; restaore le reste de PL.
JNNIL A1,PUT6 ; EQUAL a ramene T.
GETCDR A4,A4 ; avance sur P-liste.
JPLIST A4,PUT4 ; fin P-liste au milieu ?!?
PUT5: ; l'indicateur n'etait pas la.
POP P,A3 ; restore IND.
POP P,A2 ; restore PVAL.
POP P,A1 ; restore PL.
JRST ADDPROP ; on cre tout ca.
PUT6: ; l'indicateur etait present.
POP P,A3 ; restore IND.
POP P,A2 ; restore PVAL.
POP P,A1 ; restore PL.
PJRST PUT2 ; vers le changement de P-val.
; P-L- : GET
; (GET PL IND) [2SUBR]
GET:
JPATOM A1,GET0 ; PL est un atome litteral.
JNLIST A1,FALSE ; en cas de nombre ou chaine.
GET0:
CAML A2,BCNUM ; si IND n'est pas litatom ou inumb
JRST GET5 ; vers GET avec EQUAL.
;;; GET avec EQP.
SKLIST A1 ; ON PREND LA LISTE TELLE QUELLE.
GET1:
GETCDR A1,A1 ; AVANCE DANS LA P-LISTE.
JNLIST A1,VPOPJ ; FIN P-LISTE.
GETCAR A1,A3 ; RECUP INDIC P-LIST
CAIN A3,(A2) ; EQP SUFFIT DONC.
PJRST CADR ; C'EST LE BON.
GETCDR A1,A1 ; AVANCE EN P-LISTE.
JPLIST A1,GET1 ; FIN PLIST AU MILIEU ?!?
POPJ P,
GET5: ;;; GET avec EQUAL.
PUSH P,A2 ; sauve IND
SKLIST A1
GET6:
GETCDR A1,A1 ; AVANCE EN P-LISTE.
JNLIST A1,P.P ; FIN P-LISTE.
PUSH P,A1 ; SAUVE LE RESTE.
GETCAR A1,A1 ; RECUP L'INDIC
MOVE A2,-1(P) ; RECUP IND
PUSHJ P,EQUAL
POP P,A3
EXCH A1,A3 ; A1 <- PL, A3 <- RESULT EQ.
JUMPN A3,[POP P,A2 ; C'EST LE BON.
JRST CADR]
GETCDR A1,A1
JPLIST A1,GET6 ; LA LISTE CONTINUE.
PJRST P.P ; FIN P-LISTE AU MILIEU ?!?
; P-L- : GETL
; (GETL PL LIND) [2SUBR]
; ramene une sous P-liste de PL.
;?!? il faudrait prevoir un GETL rapide utilisant un MEMQ open.
GETL:
PUSH P,A2 ; sauve LIND
SKLIST A1
GETL1:
GETCDR A1,A1 ; avance en P-LISTE.
JNLIST A1,P.P ; fin P-LISTE.
PUSH P,A1 ; sauve le reste.
GETCAR A1,A1 ; recup INDIC P-LISTE.
MOVE A2,-1(P) ; recup LIND
PUSHJ P,MEMBER
POP P,A3
EXCH A1,A3 ; A1 <- PL, A3 <- result MEMQ.
JNNIL A3,P.P ; c'est le bon.
GETCDR A1,A1
JPLIST A1,GETL1
PJRST P.P ; FIN P-LISTE.
; P-L- : REMPROP
; (REMPROP PL IND) [2SUBR]
; enleve l'indicateur IND (et sa Pval correspondante)
; sur la P-liste PL.
REMPROP:
JPATOM A1,REMPR0 ; en cas d'ATOM.
JNLIST A1,FALSE ; en cas de nombre ou de chaine.
REMPR0:
MOVEI A4,(A1) ; preserve A1 pour le retour.
CAML A2,BCNUM ; si IND n'est pas litatom ou inumb
JRST REMPR3 ; vers REMPROP lent.
;;; REMPROP rapide avec EQP.
SKLIST A4 ; si PL est un atome,
; on prend son CDR.
; pour des listes le resultat n'est pas garanti !!!!!!!!!!
REMPR1:
GETCDR A4,A3
JNLIST A3,VPOPJ ; fin de la P-liste.
GETCAR A3,A5 ; indicateur suivant.
CAIN A2,(A5) ; c'est cui-la ?
JRST REMPR2 ; ouaip.
GETCDR A3,A4 ; avance en P-liste.
JPLIST A4,REMPR1 ; ca continue.
POPJ P, ; fin P-liste au milieu ?!?
REMPR2: ; enleve fisiquement l'indicateur.
GETCDR A4,A3
GETCDR A3,A3
GETCDR A3,A3
PUTCDR A4,A3 ; shunt 2 elements.
POPJ P, ; voila le travail.
REMPR3: ;;; REMPROP lent avec EQUAL.
PUSH P,A1 ; sauve PL pour le retour.
PUSH P,A2 ; sauve IND.
SKLIST A4 ; si PL est un atome,
; on prend son CDR.
; pour des listes le resultat n'est pas garanti !!!!!!!!!!
REMPR4:
GETCDR A4,A3 ; avance en P-liste.
JNLIST A3,REMPR6 ; fin de la P-liste.
PUSH P,A3 ; sauve le reste.
GETCAR A3,A1 ; a1 <- indicateur suivant.
MOVE A2,-1(P) ; recup IND.
PUSHJ P,EQUAL
POP P,A3 ; recup le reste de PL.
JNNIL A1,REMPR5 ; EQUAL a ramene T.
GETCDR A3,A4 ; avance en P-liste.
JPLIST A4,REMPR4 ; elle continue.
JRST REMPR6 ; fin de la P-liste au milieu ?!?
REMPR5: ; l'indicateur a ete trouve.
GETCDR A4,A3
GETCDR A3,A3
GETCDR A3,A3
PUTCDR A4,A3 ; shunt de 2 elements.
REMPR6: ; on rentre.
POP P,A2 ; restore IND
POP P,A1 ; rest PL
POPJ P, ; voila le travail !
; DEF : DE DF DG DMI DMO
; DE DF DM DMO DMI definition de LAMBDA expression.
DMO:
SKIPA A3,[MACOUT]
DMI:
MOVEI A3,MACIN
JRST DEF
DM:
MOVEI A3,MACRO
JRST DEF
DF:
SKIPA A3,[FEXPR]
DE:
MOVEI A3,EXPR
DEF:
; [PAT] AUG 7 1978.
; A1 EST:
; OU BIEN (NOM LARG S1 ... SN).
; OU BIEN ((NOM . LARG) S1 ... SN).
GETCAR A1,A2
JNLIST A2,DEF2 ; PREMIER OU-BIEN.
GETCDR A2,A5 ; SECOND OU-BIEN.
PUTCDR A2,A1
PUTCAR A1,A5
MOVE A1,A2
DEF2:
GETCDR A1,A2 ; A2 <- (LARG S1 ... SN).
GETCAR A1,A1 ; A1 <- FN.
SKATOM A1 ; A1 doit etre un atome litteral.
PJRST ERBDEF ; vers erreur BAD DEFINITION.
HRLI A2,LAMBDA
CONSL A2,, ; A2 <- (LAMBDA . (LARG S1 ... SN)).
PJRST PUT
; (DG FN LARG S1 ... SN) - FSUBR -
DG:
GETCDR A1,A2 ; A2 <- (LARG S1 ... SN)
GETCAR A1,A1 ; A1 <- FN.
SKATOM A1 ; A1 doit etre un atome litteral.
PJRST ERBDEF ; vers erreur BAD DEFINITION.
HRLI A2,GAMMA
CONSL A2 ; A2 <- (GAMMA . (LARG S1 ... SN))
MOVEI A3,EXPR
PJRST PUT
; DEF : AUTOLOAD DMC
; (AUTOLOAD FILE FN1 ... FNN) [FSUBR]
AUTOLOAD:
UNCONS A1,A1,A2 ; A1 <- le nom du fichier.
SKATOM A1 ; le nom du fichier doit etre un atome litteral.
PJRST ERBDEF ; sinon erreur BAD DEFINITION.
PUTCAR A1,A1 ; protection de 'file'
; en faisant un noeud dans son CAR.
HRLI A1,A.AUTO ; on cre [AUTOLOAD,,file]
JRST AUTOL2 ; vers la boucle des noms de fonctions.
AUTOL1:
UNCONS A2,A3,A2 ; A3 fonction suivante.
SKATOM A3 ; les fonctions doivent etre des atomes litteraux.
PJRST ERBDEF ; vers BAD DEFINITION.
MOVEM A1,MEM+5(A3) ; force [AUTOLOAD,,FILE]
AUTOL2:
JPLIST A2,AUTOL1 ; yen a encore.
TLZ A1,-1 ; enleve l'indicateur AUTOLOAD
POPJ P, ; pour ramener FILE.
; (DMC caractere larg ... body ...) [FSUBR]
DMC:
GETCAR A1,A2 ; A2 <- le caractre.
PUSHJ P,ST1CHR ; test si mono (result -> A7).
PJRST ERBDEF ; c'est pas mono-caractere.
GETCDR A1,A2 ; A2 <- ( larg ... body ..)
HRLI A2,LAMBDA ;
CONSL A2,, ; cre (LAMBDA (larg) ... body ...)
HRLM A2,TABCAR(A7) ; force la nouvelle definition.
GETCAR A1,A1 ; ramene donc le caractere.
POPJ P,
SUBTTL FONCTIONS DE RECHERCHE
$$RECH::
PRINTX /10-RECH.MOD/
CAAADR: SKIPA A1,MEM(A1)
CAAAAR: GETCAR A1,A1
JRST CAAAR
CADADR: SKIPA A1,MEM(A1)
CADAAR: GETCAR A1,A1
JRST CADAR
CAADDR: SKIPA A1,MEM(A1)
CAADAR: GETCAR A1,A1
CAADR: SKIPA A1,MEM(A1)
CAAAR: GETCAR A1,A1
JRST CAAR
CADDDR: SKIPA A1,MEM(A1)
CADDAR: GETCAR A1,A1
CADDR: SKIPA A1,MEM(A1)
CADAR: GETCAR A1,A1
CADR: SKIPA A1,MEM(A1)
CAAR: GETCAR A1,A1
CAR: GETCAR A1,A1
POPJ P,
CDAADR: SKIPA A1,MEM(A1)
CDAAAR: GETCAR A1,A1
JRST CDAAR
CDADDR: SKIPA A1,MEM(A1)
CDADAR: GETCAR A1,A1
CDADR: SKIPA A1,MEM(A1)
CDAAR: GETCAR A1,A1
JRST CDAR
CDDADR: SKIPA A1,MEM(A1)
CDDAAR: GETCAR A1,A1
JRST CDDAR
CDDDDR: SKIPA A1,MEM(A1)
CDDDAR: GETCAR A1,A1
CDDDR: SKIPA A1,MEM(A1)
CDDAR: GETCAR A1,A1
CDDR: SKIPA A1,MEM(A1)
CDAR: GETCAR A1,A1
CDR: GETCDR A1,A1
POPJ P,
; RECH : MEMQ MEMBER CNTH NTH
; (MEMQ AT L ) - SUBR - [AVEC EQ]
; (MEMBER S1 S2) - SUBR - [ACEC EQUAL]
MEMBER:
SKIPA A6,[EQUAL]
MEMQ:
MOVEI A6,EQ
EXCH A1,A2 ; FACILE RETOUR.
CAMGE A2,BCNUM ; si AT est litatom ou inumb,
JRST MEMQ5 ; MEMQ RAPIDE AVEC EQP.
;;; MEMQ lent avec EQ ou EQUAL.
MOVEM A6,TEMP$F ; SAUVE LA FONCTION A XCT.
MOVEM A2,TEMP$T ; SAUVE LE TEST.
JRST MEMQ2
MEMQ1:
PUSH P,A1 ; SAUVE L.
GETCAR A1,A1 ; ELEM SUIV.
MOVE A2,TEMP$T ; RECUP LE TEST.
PUSHJ P,@TEMP$F ; EQ OU EQUAL.
MOVEI A3,(A1) ; A3 <- RESULT COMPARAISON.
POP P,A1 ; RESTAURE L.
JNNIL A3,VPOPJ ; IL EXISTE BIEN.
GETCDR A1,A1 ; AVANCE DANS L.
MEMQ2:
JPLIST A1,MEMQ1 ; L N'EST PAS FINIE.
POPJ P,
MEMQ4:
GETCAR A1,A3
CAIN A3,(A2) ; EQP SUFFIT DONC.
POPJ P,
GETCDR A1,A1
MEMQ5:
JPLIST A1,MEMQ4 ; CA ROULE.
POPJ P,
; (NTH N L) CNTH N L == (CAR (NTH N L))
CNTH:
PUSH P,[CAR]
NTH:
MOVE A5,MEM(A1) ; A5 = NUMERO DE L'ELEMENT.
MOVEI A1,(A2)
JRST NTH2
NTH1:
GETCDR A1,A1
SNLIST A1 ; FIN DE LA LISTE.
NTH2:
SOJG A5,NTH1 ; ON COMPTE.
POPJ P,
; RECH : LAST
;------ refaire plus rapide avec LENGTH -----
; (LAST L [N]) - SUBR - RAMENE LES N DERNIERS ELEMENTS
; DE L. SI N=NIL , N=1.
LAST:
JPNIL A2,LAST9 ; N=NIL.
JNLIST A1,VPOPJ ; QU'EST-CE-QUE CA VEUT DIRE!
JNNUMB A2,LAST9 ; SI N # NB => N=1.
MOVE A5,MEM(A2) ; RECUP LA VALEUR N.
SOJLE A5,LAST9 ; < 0.
MOVEI A2,(A1)
GETCDR A2,A3
JNLIST A3,VPOPJ ; YA QU'UN ELEMENT.
LAST3: ; FORWARD.
GETCDR A3,A4
JNLIST A4,LAST5 ; FIN DU FORWARD.
PUTCDR A3,A2
MOVEI A2,(A3)
MOVEI A3,(A4)
JRST LAST3
LAST5: ;BACKWARD.
CAIN A2,(A1)
POPJ P,
GETCDR A2,A4
PUTCDR A2,A3
SOJN A5,LAST6
PUSH P,A2
PUSH P,[A1.P]
LAST6:
MOVEI A3,(A2)
MOVEI A2,(A4)
JRST LAST5
; LAST NORMAL..
LAST8:
SKIPA A1,A2
LAST9:
SKIPA A2,A1
GETCDR A1,A2
JPLIST A2,LAST8
POPJ P,
; RECH : TYPEP TYPEFN TYPNUMB
; (TYPEP S) [1SUBR] [S -> A1]
; ramene le type de S :
; LITATOM si atome litteral, NUMBP si nombre,
; STRINGP si chaine, LISTP si liste, NIL si autre chose....
TYPEP:
MOVEI A2,(A1) ; argument dans A2.
MOVEI A1,A.LSTP
JPLIST A2,VPOPJ ; c'est une liste.
MOVEI A1,A.LITAT
JPATOM A2,VPOPJ ; c'est un atome litteral.
MOVEI A1,A.NUMBP
CAMGE A2,BSTRG
POPJ P, ; c'est un nombre.
MOVEI A1,A.STRIP
POPJ P, ; c'est une chaine.
; (TYPEFN A) - SUBR -
; ramene le type de la fonction A.
TYPEFN:
JNATOM A1,FALSE ; c'est pas un atome litteral.
MOVEI A4,(A1)
GETCDR A1,A2 ; recup sa P-liste.
JUMPE A2,TYPEF2 ; ya pas de P-liste.
TYPEF1:
GETCAR A2,A1 ; indicateur -> A2.
CAIE A1,EXPR ; test EXPR.
CAIN A1,FEXPR ; test FEXPR.
POPJ P,
CAIE A1,MACIN ; test MACIN.
CAIN A1,MACOUT ; test MACOUT.
POPJ P,
CAIN A1,MACRO ; test MACRO.
POPJ P,
GETCDR A2,A2 ; avanve en P-liste.
GETCDR A2,A2 ; encore.
JUMPN A2,TYPEF1 ; la P-liste continue
TYPEF2:
HLRZ A1,MEM+5(A4) ; recup l'indicateur special.
POPJ P, ; et c'est fini.
; (TYPNUMB n) [1SUBR]
; ramene NIL si pas un nb, FIX si nb fixe, FLOAT si nb flottant.
TYPNUMB:
JNNUMB A1,FALSE ; c'est pas un nb.
CAML A1,BCNUM ; nb cree ?
SKIPN MEM+1(A1) ; nb flottant ?
SKIPA A1,[A.FIX] ; il est fixe.
MOVEI A1,A.FLO ; il est flottant.
POPJ P, ; voila.
; RECH : ASSOC CASSOC ASSQ CASSQ
; FONCTIONS DE RECHERCHE SUR A-LISTE (LISTE DE LISTES)
; A1 <- ATOM/LISTE A2 <- A-LISTE
; ASSOC ET SES FRERES
ASSOC:
SKIPA A7,[CAR]
CASSOC:
MOVEI A7,CDAR
MOVEI A6,EQUAL
JRST ASSO1
ASSQ:
SKIPA A7,[CAR]
CASSQ:
MOVEI A7,CDAR
MOVEI A6,EQ
ASSO1: ;;; ASSOC long.
CAMGE A1,BCNUM ; si litatom ou inumb,
JRST ASSO5 ; vers ASSOC rapide.
PUSH P,A7 ; PREPARE LE POPJ FINAL
MOVEM A6,TEMP$F ; SAUVE LE PREDICAT
EXCH A1,A2 ; POURR FACILITE LE RETOUR.
MOVEM A2,TEMP$T ; SAUVE LE TEST.
JRST ASSO3
ASSO2:
GETCDR A1,A1
ASSO3:
JPNIL A1,VPOPJ ; ELLE EST VIDE.
PUSH P,A1
GETCAR A1,A1
GETCAR A1,A1 ;
MOVE A2,TEMP$T ; RECUP LE TEST.
PUSHJ P,@TEMP$F ; EQ OU EQUAL.
POP P,A3
EXCH A1,A3 ; A3 <- RESULT DU TEST.
JPNIL A3,ASSO2 ; C'EST PAS BON.
POPJ P, ; C'EST OK.
ASSO5: ;;; ASSOC court.
EXCH A1,A2 ; FACILITE LE TEST.
JRST ASSO7
ASSO6:
GETCAR A1,A3
GETCAR A3,A3
CAIN A3,(A2) ; EQP SUFFIT DONC.
PJRST (A7) ; C'EST OK (VERS CAR OU CADR).
GETCDR A1,A1 ; ELEMENT SUIVANT.
ASSO7:
JPLIST A1,ASSO6 ; ON CONTINUE.
POPJ P, ; C'EST FAUX.
; STACK : PUSH POP PSTACK
; (PUSH S1 ... SN) [NSUBR] EMPILE S1 ... SN .
$PUSH:: ; (PUSH s) [1SUBR] compilateur
TDZA A4,A4 ; NIL dans le reste.
APUSH:
UNCONS A4,A1,A4 ; argument suivant.
AOS A5,USTCKC ; recup + increm PP.
CAML A5,USTCKE ; ca rentre ?
JRST ERSO ; NAN erreur.
MOVEM A1,(A5) ; ouaip on le range.
JNNIL A4,APUSH ; il en reste.
POPJ P,
; (POP [n]) [1SUBR]
; si (POP) depile normalement,
; si (POP n) utile le PP comme registre d'index.
APOP:
JNNIL A1,APOP1 ; c'est pour l'indexation.
$POP:: ; (POP) [0SUBR] compilateur
SOS A5,USTCKC ; recup + decrem PP.
CAMGE A5,USTCKB ; il en reste en pile ?
JRST ERSU ; NAN : erreur.
MOVE A1,1(A5) ; ouaip on le ramene.
POPJ P,
APOP1:
MOVE A5,USTCKC ; recup PP.
SUB A5,MEM(A1) ; calcul l'adresse desiree.
CAMGE A5,USTCKB ; on deborde ?
JRST ERSU ; ouaip.
CAML A5,USTCKE ; encore ?
JRST ERSO ; ouaip.
MOVE A1,(A5) ; bon.
POPJ P, ; voila.
; (PSTACK [n]) [1SUBR]
; POSITIONNE LE P.P. Ramene la val cour du P.P.
PSTACK:
JNNUMB A1,PSTAK1 ; c'est juste un GET.
MOVE A5,MEM(A1) ; a5 <- la val.
CAMGE A5,USTCKB ; teste de debordement de pile.
JRST ERSU
CAML A5,USTCKE
JRST ERSO
MOVEM A5,USTCKC ; force la nouvellee val du P.P.
$PSTACK:: ; (PSTACK) [0SUBR] compilateur
PSTAK1:
MOVE A5,USTCKC
PJRST CRANUM ; ramene le P.P. courant
SUBTTL FONCTIONS DE MODIFICATION
$$MODI::
; (SETQ OB1 VAL1 ... OBN VALN) [FSUBR] ramene VALN
SETQ1:
MOVEI A1,(A3)
SETQ:
UNCONS A1,A2,A1
GETCDR A1,A3
SAVR A2,A3 ; SAUVE OBJ PUIS LE RESTE.
PUSHJ P,EVALCA ; EVALUE VAL
BABYL A3,A2 ; REST RESTE ET OBJ.
PUTCAR A2,A1
JNNIL A3,SETQ1 ; C'EST PAS FINI.
POPJ P,
; (SET OB1 VAL1 ... OBN VALN) [NSUBR] RAMENE VALN
; (SETQQ OB1 VAL1 ... OBN VALN) [FSUBR] RAMENE VALN
SETQQ:
MOVEI A4,(A1) ; COMPATIBILITE SUBR-FSUBR.
JRST SET
SET1:
UNCONS A4,A2,A4 ; A2 <- OBJ
UNCONS A4,A1,A4 ; A1 <- VAL
PUTCAR A2,A1 ; AFFECT.
SET:
JNNIL A4,SET1
POPJ P,
; (SYNONYM A1 A2) [2SUBR]
; met les indicateurs speciaux et les birs speciaux de A2 -> A1
SYNONY:
MOVE A5,MEM+5(A2) ; INDIC - ADR
MOVEM A5,MEM+5(A1)
HLR A5,MEM+4(A2) ; BITS SPEC
HRLM A5,MEM+4(A1)
POPJ P,
; MODF : RPLACA RPLACD RPLACB NCONC NCONC1 EXCH
; (RPLACA OBJ VAL) - SUBR - RAMENE OBJ.
; (RPLACD OBJ VAL) - SUBR - RAMENE OBJ.
; (RPLACB obj new-obj) [2SUBR]
RPLACA:
PUTCAR A1,A2 ; AFFECTATION OBJ.
POPJ P,
RPLACD:
PUTCDR A1,A2
POPJ P,
RPLACB:
MOVE A3,MEM(A2) ; super-rapide en 2 mots !
MOVEM A3,MEM(A1)
POPJ P,
; (NCONC L1 L2) - SUBR - LIE L1 ET L2 PHYSIKEMENT.
; (NCONC1 L A1 ... AN) - SUBR - == (NCONC L (LIST A1 ... AN)) .
; RAMENE LE NOUVEL L1 .
NCONC1:
UNCONS A4,A1,A2 ; COMPATIBILITE NSUBR-2SUBR
NCONC:
JPNIL A1,A2POPJ ; SI NULL A1 -> A2.
JPNIL A2,VPOPJ ; YA PAS DE A2.
MOVEI A4,(A1) ; FACILITE LE RETOUR.
NCONC2:
GETCDR A4,A3
JNLIST A3,NCONC3 ; 5 intrs / 2 elems
GETCDR A3,A4
JPLIST A4,NCONC2
PUTCDR A3,A2 ; liaison physique.
POPJ P,
NCONC3:
PUTCDR A4,A2 ; liaison physik du 2eme type.
POPJ P,
; (EXCH v1 v2) [FSUBR] echange les 2 c-vals
EXCH:
UNCONS A1,A3,A1 ; A3 <- var1.
GETCAR A1,A4 ; A4 <- var2.
GETCAR A3,A1 ; A1 <- C-VAL var1.
GETCAR A4,A2 ; A2 <- C-VAL var2.
PUTCAR A3,A2
PUTCAR A4,A1
POPJ P, ; ramene donc la c-val de var1 (au debut).
; MODF : NEXTL NEWL SMACH ATTACH
; (NEXTL L) - FSUBR - RAMENE (CAR L) & L:=(CDR L) .
; (NEWL L S) - FSUBR - (SET L (CONS #S #L))
NEXTL:
GETCAR A1,A2 ; A2:=L .
GETCAR A2,A3 ; A3:=CVAL
UNCONS A3,A1,A3 ; A1 <- (CAR CVAL) A3 <- (CDR CVAL)
PUTCAR A2,A3 ; L:=(CDR L) .
POPJ P,
NEWL:
UNCONS A1,A2,A1 ; A1 <- L ; A2 <- S .
PUSH P,A2 ; SAUVE S
PUSHJ P,EVALCA ; EVALUE (CAR L)
POP P,A2 ; REST S
GETCAR A2,A3 ; A3 <- (CVAL L)
CONSL A3,A1 ; A3 <- (EVAL (CAR S)).(CVAL L)
PUTCAR A2,A3 ; METS LA NOUVELLE VALEUR
MOVE A1,A3
POPJ P, ; RETOURNE LA NOUVELLE LISTE.
; (SMASH S) - SUBR - (RPLACA P (CADR P)) /ET/ (RPLACD P (CDDR P))
SMASH:
JNLIST A1,VPOPJ ; A1 = ATOME.
GETCDR A1,A2
UNCONS A2,A3,A4 ; A3 <- CADR P ; A4 <- CDDR P .
PUTCAR A1,A3 ; RPLACA P (CADR P)).
PUTCDR A1,A4 ; (RPLACD P (CDDR P)).
POPJ P,
; (ATTACH S1 S2) - SUBR -
; (RPLACD S2 (CONS (CAR S2)(CDR S2))) /ET/ (RPLACA S2 S1)
ATTACH:
MOVE A3,MEM(A2)
CONSL A3,, ; COPY LA 1ERE CELL DE S2.
PUTCAR A2,A1 ; MODIFIE S2.
PUTCDR A2,A3
MOVEI A1,(A2) ; RAMENE NEW S2.
POPJ P,
; MODF : FREVERSE INCR DECR
; (FREVERSE L) [SUBR 1] REVERSE PHYSIQUE DE L
FREVERSE:
SETZ A2, ; PREPARE POINTEUR ARRIERE.
JNLIST A1,VPOPJ ; ON SAIT JAMAIS.
FREV2:
GETCDR A1,A3 ; ELEMENT AVANT SUIVANT.
PUTCDR A1,A2 ; EFFECTUE LE CHAINAGE.
MOVEI A2,(A1) ; POSITIONNE POINT ARRIERE.
MOVEI A1,(A3) ;
FREV1:
JPLIST A1,FREV2 ; ON AVANCE DANS LA LISTE.
MOVEI A1,(A2)
POPJ P, ; C'EST FINI (A1 POINTE SUR LE DERNIER).
; (INCR I) - FSUBR - == (SETQ I (ADD1 I))
; (DECR I) - FSUBR - == (SETQ I (SUB1 I))
INCR:
SKIPA A6,[FADD1]
DECR:
MOVEI A6,FSUB1
GETCAR A1,A1 ; A1 <- I .
PUSH P,A1 ; SAUVE I.
GETCAR A1,A1 ; A1 <- CVAL DE I.
SKNUMB A1 ; c'est un nb.
MOVEI A6,CRAZER ; nan : on ramene 0.
PUSHJ P,(A6) ; appel 1+ ou 1-
POP P,A2 ; recup l'atome.
PUTCAR A2,A1 ; force sa new-val.
POPJ P, ; voila !
SUBTTL FONCTIONS DE CREATION
$$CRAT::
PRINTX /11-CREAT/
; (XCONS S1 S2 ) => (S2 . S1)
; (CONS S1 S2) => (S1 . S2)
; (NCONS s) => (S . NIL)
CONS:
EXCH A1,A2
XCONS:
CONSL A1,A2
POPJ P,
NCONS:
CONSL A1,A1,NIL
POPJ P,
; (MCONS S1 ... SN) = (CONS S1 (CONS S2 ... (CONS SN-1 SN) ... ))
MCONS:
UNCONS A4,A1,A4 ; AVANCE DANS LARG.
JPNIL A4,VPOPJ ; C'EST FINI.
PUSH P,A1 ; SAUVE LE CAR.
PUSHJ P,MCONS ; RECURSE SUR LES CDRS.
POP P,A2 ; RECUP LE CAR.
CONSL A1,A2
POPJ P,
; (DCONS A L) - DISTRIBUTIVE CONS -
DCONS:
JNLIST A2,CONS
CONSL A4,NIL,NIL ; PREPARE LISTE RESULTAT.
MOVEI A5,(A4) ; A5 = LAST.
DCONS1:
UNCONS A2,A3,A2 ; AVANCE DANS L
CONSL A3,A1,
CONSL A3,A3,NIL
ADLIST A5,A3 ; CRE LA LISTE RESULTAT.
JPLIST A2,DCONS1 ; YEN A ENCORE.
GETCDR A4,A1 ; RECUP LA VRAIE LISTE RESULT.
POPJ P, ; VOILA.
; CRAT : LIST LINEAR ;
; (LIST s1 ... sN) [NSUBR]
LIST:
MOVEI A1,(A4)
POPJ P,
; (LINEAR S1 ... SN) - NSUBR - [S1 ...SN -> A4]
; RAMENE LA LISTE DE TOUS LES ATOMES DE S1 ... SN
LINEAR:
JPNIL A4,FALSE ; YA PAS D'ARGUMENT.
CONSL A2,NIL,NIL ; PREPARE LISTE RESULT.
PUSH P,A2 ; SAUVE.
PUSH P,[PD.P]
LINEA1:
JPLIST A4,LINEA2
CONSL A4,A4,NIL ; C'EST UN ATOME.
ADLIST A2,A4 ; JE L'ACCROCHE.
POPJ P, ; VOILA.
LINEA2:
UNCONS A4,A4,A3 ; AVANCE DANS A4.
PUSH P,A3 ; SAUVE LE RESTE.
PUSHJ P,LINEA1 ; APPLATI SON CAR.
POP P,A4
JNNIL A4,LINEA1 ; APPLATI SON CDR.
POPJ P, ; FIN DE LA LISTE.
; CRAT : SUBST [PAT] AUG 17 1978
; (SUBST NEW OLD EXP) - SUBR -
; RAMENE UNE COPIE DE "EXP" EN SUBSTITUANT
; "NEW" A TOUTES LES OCCURENCES DE "OLD" DANS "EXP".
; (DE SUBST (NEW OLD EXP)
; (COND ((EQUAL OLD EXP) NEW)
; ((ATOM EXP) EXP)
; ((CONS (SUBST (NEW OLD (CAR EXP)))
; (SUBST (NEW OLD (CDR EXP)))))))
SUBST:
CAIN A1,(A2) ; si NEW et OLD sont les memes pointeurs,
JRST [MOVEI A1,(A3) ; il vaut mieux utiliser COPY.
JRST COPY]
SAVR A1,A2 ; SAVE NEW ET OLD.
HRRZM P,TEMP$0 ; POUR LES TROUVER + TARD.
MOVEI A1,(A3) ; EXP DANS A1, OLD DANS A2.
PUSHJ P,SUBST1 ; VU QUE A2 VIT ENCORE.
SUB P,[2,,2] ; DEPILER OLD ET NEW.
POPJ P, ; RETOUR .
SUBST0:
MOVE A2,@TEMP$0 ; OLD DANS A2, EXP DANS A1.
SUBST1:
MOVEM A1,TEMP$1 ; SAUVER EXP.
PUSHJ P,EQUAL ; EXP = OLD ? , TUE A2.
MOVE A2,TEMP$1 ; EXP DANS A2.
JUMPE A1,SUBST2 ; NON.
MOVE A2,TEMP$0 ; OUI. ON ACCEDE A LA PILE.
MOVE A1,-1(A2) ; NEW DANS A1.
POPJ P, ; ET BYE.
SUBST2:
JNLIST A2,A2POPJ ; RETOURNER EXP A L'ENVOYEUR
; SI EXP PAS UNE LISTE.
UNCONS A2,A1,A2 ; CAR EXP DANS A1, CDR DANS A2.
PUSH P,A2 ; SAUVER LE CDR.
PUSHJ P,SUBST0 ; SUBSTER LE CAR.
EXCH A1,(P) ; ECHANGER LES DANSEUSES ...
PUSHJ P,SUBST0 ; ET SUBSTER LE CDR.
POP P,A2
CONSL A1,A2,A1 ; ET CONSER LE TOUT.
POPJ P, ; FLOUAOUFF ...
; CRAT: SUBLIS [PAT] AUG 14 78
; (DE SUBLIS (A E)
; (IF (ATOM E) (LET ((X (ASSQ E A)))
; (IF X (CDR X) E))
; (CONS (SUBLIS A (CAR E)) (SUBLIS A (CDR E)))))
;
; A = UNE A-LISTE, E = UNE S-EXPRESSION.
SUBLIS:
EXCH A1,A2 ; POUR UTILISER ASSQ
SUBLI1: ; A1: LA SEXPR, A2: LA A-LISTE
JPLIST A1,SUBLI2
PUSH P,A1
PUSH P,A2
PUSHJ P,ASSQ
POP P,A2
JUMPN A1,SUBLI3
POP P,A1
POPJ P,
SUBLI2:
UNCONS A1,A1,A3
PUSH P,A3
PUSHJ P,SUBLI1
EXCH A1,(P)
PUSHJ P,SUBLI1
POP P,A3
CONSL A1,A3,A1
POPJ P,
SUBLI3:
SUB P,[1,,1]
GETCDR A1,A1
POPJ P,
; CRAT : COPY
; (COPY L) [1SUBR] ramene une copie de L.
; ne traite pas les listes circulaires.
COPY:
JNLIST A1,VPOPJ ; ya rien a faire.
COPY0:
CONSL A2,NIL,NIL ; prepare la liste resultat.
PUSH P,A2 ; on al sauve.
COPY1:
UNCONS A1,A3,A1 ; avance dans L.
JNLIST A3,COPY2 ; l'element est atomique.
PUSH P,A1 ; sinon , on sauve le reste.
PUSH P,A2 ; et LAST,
MOVEI A1,(A3)
PUSHJ P,COPY0 ; et on recurse sur les CARs.
POP P,A2 ; recupere LAST.
POP P,A3 ; recupere le reste.
EXCH A1,A3
COPY2: ; creation de la nouvelle liste.
CONSL A3,A3,NIL
PUTCDR A2,A3
MOVEI A2,(A3) ; repositionne LAST.
JPLIST A1,COPY1 ; yen a encore.
PUTCDR A2,A1 ; des fois quyaurait des paires pointees.
POP P,A1 ; recup la liste cree.
GETCDR A1,A1
POPJ P,
; CRAT : OBLIST PAIRLIS ;
; (OBLIST) [ SUBR 0 ]
; ramene la longue liste des atomes litteraux sans l'atome UNDEF
; qui provoque des erreurs A8 beaucoup trop souvent...
; La liste ramenee est en realite inversee / a la realite.
OBLIST:
MOVE A2,CATOM ; debut liste des atomes.
CONSL A1,A2,NIL ; on CONS le 1er.
OBLIS1:
HRRE A2,MEM+4(A2) ; atome suivant.
JUMPL A2,VPOPJ ; yen a pu.
CAIN A2,UNDEF ; on saute UNDEF.
JRST OBLIS1
CONSL A1,A2
JRST OBLIS1
; (PAIRLIS LVAR LVAL ALIST) - SUBR -
; CONSTRUCTION D'UNE NOUVELLE A-LISTE.
PAIRLIS:
CONSL A4,NIL,NIL ; PREP LISTE RESULT.
PUSH P,A4 ; JLE SAUVE
JRST PAIRL2 ; ON Y VA.
PAIRL1:
UNCONS A1,A6,A1 ; A6 <- VAR
UNCONS A2,A5,A2 ; A5 <- VAL
CONSL A5,A6 ; (VAR . VAL)
CONSL A5,A5,NIL ; ((VAR . VAL))
ADLIST A4,A5
PAIRL2:
JPLIST A1,PAIRL1 ; YEN A ENCORE
JPNIL A1,PAIRL3 ; LARG NORMALE.
CONSL A2,A1 ; BIND ATOME.
CONSL A2,A2,NIL
ADLIST A4,A2
PAIRL3:
PUTCDR A4,A3 ; METS L'ANCIENNE A-LISTE EN QUEUE.
PJRST PD.P
; CRAT : DELQ DELETE ;
; (DELQ A L) [EQ]
; (DELETE S L) [EQUAL]
; RAMENE UNE COPIE DU TOP-LEVEL DE L SANS LES OCCURENCES DE A/L
; PILE : //FIRST/1ER ARG/(CDR L)/(CAR L) ...
; USE : TEMP$F + TEMP$L
DELETE:
SKIPA A6,[EQUAL]
DELQ:
MOVEI A6,EQ
CONSL A3,NIL,NIL ; PREPAR LISTE RESULTAT.
PUSH P,A3 ; ON LA SAUVE.
CAMGE A1,BCNUM ; si litatom ou inumb,
JRST DELQ5 ; VERS DELQ RAPIDE.
MOVEM A6,TEMP$F ; SAUVE LA FN A EXECUTER.
MOVEM A3,TEMP$L ; SAUVE LAST.
PUSH P,A1 ; SAUVE 1ER ARG.
MOVE A3,A2
JRST DELQ3 ; ON Y VA.
DELQ1:
UNCONS A3,A2,A3 ; AVANCE DANS L
PUSH P,A3 ; SAUVE LE CDR
PUSH P,A2 ; SAUVE LE CAR
MOVE A1,-2(P) ; RECUP 1ER ARG
PUSHJ P,@TEMP$F ; EQ OU EQUAL
POP P,A2
JNNIL A1,DELQ2 ; C'EST A ENLEVER
MOVE A1,TEMP$L ; RECUP LAST.
CONSL A2,A2,NIL
PUTCDR A1,A2
MOVEM A2,TEMP$L ; SAUVE LAST.
DELQ2:
POP P,A3 ; RECUP LE RESTE DE L
DELQ3:
JPLIST A3,DELQ1 ; IL EN RESTE.
PJRST PPD.P
DELQ4: ;;; DELQ RAPIDE AVEC EQP.
UNCONS A2,A4,A2 ; ELEMENT SUIVANT.
CAIN A4,(A1) ; EQP SUFFIT DONC.
JRST DELQ5 ; ON COPIE PAS
CONSL A4,A4,NIL
PUTCDR A3,A4
MOVEI A3,(A4)
DELQ5:
JPLIST A2,DELQ4 ; YEN A ENCORE ?
JRST PD.P ; NAN.
; CRAT : REVERSE APPEND APPEND1
; (REVERSE L [S]) - SUBR - RAMENE UNE COPIE DU TOP-LEVEL
; DE L AVEC [S] APPENDE.
REVER1:
UNCONS A1,A3,A1 ; AVANCE DANS L.
CONSL A2,A3 ; CRE LA LISTE
REVERS:
JPLIST A1,REVER1 ; LA LISTE N'EST PAS FINIE.
MOVEI A1,(A2)
POPJ P,
; (APPEND L1 L2) - SUBR -
; [ L1 -> A1 LAST -> A2 RESUL -> A3]
; (APPEND1 L A1 ... AN) = = (APPEND L (LIST A1 ... AN))
APPED1:
UNCONS A4,A1,A2 ; compatibilite Nsubr-2subr
APPEND:
JUMPE A1,A2POPJ ; SI NULL L => A2 .
JNLIST A1,CONS
PUSH P,A2 ; SAUVE L2.
CONSL A3,NIL,NIL
MOVE A2,A3
JRST APPEN2
APPEN1:
HLLZ A4,MEM(A1) ; GETCAR A1,A4 ; MOVS A4,A4
CONSL A4,,
ADLIST A2,A4
GETCDR A1,A1
APPEN2:
JPLIST A1,APPEN1 ; C'EST PAS FINI.
POP P,A4
PUTCDR A2,A4 ; ACCROCHE L2 A L1.
GETCDR A3,A1
POPJ P,
; CRAT : EXPLODE ASCII CASCII
; (EXPLODE A1 ... AN) - NSUBR -
; CONCATENE LES LISTES DES CARACTERES DES PNAMES DES ARGS
EXPLOD:
CONSL A2,NIL,NIL ; preapre laliste resultat.
PUSH P,A2 ; on la sauve.
JRST EXPLO5 ; au boulot.
$EXPLODE:: ; (EXPLODE a) [1SUBR] compilateur
MOVEI A3,(A1)
SETZ A4,
EXPLO1:
UNCONS A4,A3,A4 ; argument suivant.
PUSH P,A4 ; sauve le reste.
CAML A3,BSTRG ; # ATOM OU # NB.
JRST EXPLO4 ; AU SUIVANT.
MOVE A1,A3 ; (POUR CONVBD) .
SNATOM A3 ; PREP POINTER PNAME.
SKIPA A6,[POINT 7,MEM+1(A3),6]
PUSHJ P,CONVBD
MOVEM A6,EXPLOP ; SAUVE POINT PNAME.
JRST EXPLO3
EXPLO2:
PUSHJ P,CRACAR ; CREATION ATOM MONO-CARACTEERE
CONSL A1,A1,NIL
ADLIST A2,A1 ; FORME LA LISTE.
EXPLO3:
ILDB A7,EXPLOP ; RECUP CAR SUIV.
JUMPN A7,EXPLO2 ; C'EST PAS LA FIN DU PNAME.
EXPLO4:
POP P,A4 ; REST ARGS.
EXPLO5:
JNNIL A4,EXPLO1 ; YA ENCORE DES ARGS.
PJRST PD.P
; (ASCII N) - SUBR - CRE L'ATOME MONO-CARACT DE CODE ASCII N .
; (CASCII CH) - SUBR - RAMENE LE CODE ASCII DU CARACTERE CH.
ASCII:
MOVE A7,MEM(A1)
ANDI A7,177
JRST CRACAR
CASCII:
CAML A1,BSTRG
JRST CRAZER
SNATOM A1
SKIPA A6,[POINT 7,MEM+1(A1),6]
PUSHJ P,CONVBD
ILDB A5,A6
JRST CRANUM
; CRAT : GENSYM
; (GENSYM A1 ... AN) - NSUBR -
GENSYM:
MOVE A5,[PNAM0,,PNAME]
BLT A5,PNAME+3 ; RAZ ZONE PNMAME.
MOVE A5,[POINT 7,PNAME,6]
MOVEM A5,GENSYP
MOVNI A8,MAXCP ; INIT NB CARACT.
JUMPE A4,GENSY7 ; YA PAS D'ARGUMENTS.
GENSY1:
GETCAR A4,A1
CAML A1,BSTRG
JRST GENSY5
MOVEM A8,GENSYN
SNATOM A1
SKIPA A6,[POINT 7,MEM+1(A1),6]
PUSHJ P,CONVNB ; pour tout type de nb.
MOVE A8,GENSYN
GENSY3:
ILDB A7,A6
JUMPE A7,GENSY5 ; FIN PNAME.
IDPB A7,GENSYP
AOJN A8,GENSY3 ; PLUS DE PLACE DS PNAME.
GENSY4: ; FIN ARG (OU + DE 18 CARACT).
ADDI A8,MAXCP
DPB A8,[POINT 7,PNAME,6] ; FORCE NB CARACTERES.
JRST TRYATOM
GENSY5:
GETCDR A4,A4 ; AU SUIVANT
JUMPN A4,GENSY1
JRST GENSY4 ; YEN A PU.
GENSY7: ; GENSYM T1600.
MOVEI A7,"G"
IDPB A7,GENSYP
AOS A7,GENSYC
PUSHJ P,CONVB0
MOVNI A8,MAXCP-1
JRST GENSY3
; CRAT: LIT [PAT] AUG 16 1978
; (LIT L E F) [SUBR 3] AVEC F = FONCTION 2-AIRE
; L = UNE LISTE (X1 ... XN)
; E = UN TRUC "LE-RES"
; RAMENE (F X1 (F X2 ... (F XN E) ... ))
;
; (DE LIT (L E F) (IF (NULL L) E (F (NEXTL L) (LIT L E F))))
;
; ALGORITHME:
; L <- REVERSE L;
; TANTQUE L FAIRE E <- (F (NEXTL L) E) FTAN
; RETURN E
LIT:
PUSH P,A3 ; LA-FONC
PUSH P,A2 ; LE-RES
SETZ A2, ; POUR REVERSE
PUSHJ P,REVERSE ; INVERSER AVEC COPIE LA-LISTE
MOVEI A3,(A1) ; A3 = LA-LISTE
POP P,A1 ; LE-RES
JRST LIT3 ; VERS LE TEST-LISTE-VIDE
LIT2:
UNCONS A3,A4,A2 ; A4 = LE-CAR, A2 = LE-CDR
PUSH P,A2 ; EMPILER LE-CDR
CONSL A1,A1,NIL ; A1 <- (CONS RES NIL)
CONSL A4,A4,A1 ; A4 <- [LE-CAR LE-RES]
MOVE A1,-1(P) ; A1 = LA-FONC
PUSHJ P,APPLY ; A1 <- LE-NOUVO-RES
POP P,A3 ; LA-LISTE
LIT3:
JUMPN A3,LIT2 ; LE-TEST-LISTE-VIDE
SUB P,[1,,1] ; DEPILER 1 SLOT (I.E. LA-FONC)
POPJ P, ; FLOUFF ...
SUBTTL ARRAY
$$ARRY::
; erreur CHECK ARRAY : suppose dans
; A1 <- le nom du tableau, A2 <- l'indice defectueux.
ERCKA:
PUSHJ P,OUTBUF ; sort la deniere ligne.
MOVE A6,[POINT 7,[BYTE (7)↑D20,15,12," "," "
ASCIZ /** ARRAY error :/],6]
PUSHJ P,PRBPN ; edite ce libelle
PUSH P,A2 ; sauve l'indice.
PUSHJ P,PRIN1 ; edite le nom du tableau.
POP P,A1 ; recupere l'indice.
PUSHJ P,PRINT ; edite l'indice.
JRST REENTE ; REENTER.
; S.P. interne de calcul d'adresse d'un element.
; suppose : A1 <- le nom du tableau, A2 <- l'indice
; ramene dans A5 l'adresse de cet element.
ELEMR: ;;; y fo tester si A1 est un tablo.
JNATOM A1,ERCKA ; un tablo est un atome litteral.
HLRZ A5,MEM+5(A1) ; recup son indicateur special.
CAIE A5,ARRAY ; c'est ARRAY ?
JRST ERCKA ; nan : erreur.
ELEM: ;;; A1 est un tablo (c'est connu).
HRRZ A5,MEM+5(A1) ; recup l'adresse du tablo.
JPBIT IBIT7,ELEM1 ; il faut tester la validite de l'indice.
ADD A5,MEM(A2) ; calcul froidement l'adresse.
ADDI A5,1 ; pour sauter la taille du tablo.
POPJ P, ; voila.
ELEM1:
JNNUMB A2,ERCKA ; un indice est un nombre.
MOVE A6,(A5) ; recupere le nb d'elements du tablo.
MOVE A6,MEM(A6) ; charge dans A6 sa valeur.
MOVE A7,MEM(A2) ; charge la valeur de l'indice demande.
JUMPL A7,ERCKA ; un indice est toujours >= a 0.
CAML A7,A6 ; out of bound ?
JRST ERCKA ; helas.
ADD A5,A7 ; calcul de la veritable adresse
ADDI A5,1 ; pour sauter le nb d'elements.
POPJ P, ; voila.
CMPELM:: ;;; pour le COMPILATEUR
EXCH A1,A2 ; les args sont inverses.
PUSHJ P,ELEMR
MOVE A1,(A5)
POPJ P,
; ARRAY : DA
; (DA nom taille fnt d'init) [3SUBR]
DA:
JNATOM A1,ERCKA ; un nom de tablo est un atome litteral.
JNNUMB A2,ERCKA ; la taille doit etre un nombre.
SKIPGE MEM(A2)
JRST ERCKA ; qui + est positif.
MOVE A5,USTCKE ; recup pointeur courant zone tablo.
SUB A5,MEM(A2) ; les tablos sont alloues a l'envers.
SUBI A5,1 ; pour stocker la taille du tablo.
CAMG A5,USTCKC ; ca peut rentrer ?
JRST ERARR ; ** no room for arrays.
MOVEM A2,(A5) ; force la taille du tablo.
SKIPA A6,A5 ; A6 adresse du tablo.
DA1: ; r.a.NIL de tous les elements.
SETZM (A6)
ADDI A6,1 ; y fo incrementer avant le test.
CAMGE A6,USTCKE ; fin de cette zone ?
JRST DA1 ; yen a encore.
MOVEI A4,ARRAY ; force l'indicateur ARRAY dans
HRLM A4,MEM+5(A1) ; l'indicateur special du nom.
HRRM A5,MEM+5(A1) ; ainsi que l'adresse d'implantation.
MOVEM A5,USTCKE ; actualise le pointeur courant.
MOVEI A5,7 ; force les bits du lancement
HRLM A5,MEM+4(A1) ; super-rapide de ce tablo.
JPNIL A3,VPOPJ ; on ramene A1 (le nom).
;;; initialisation du tablo.
PUSH P,A3 ; sauve la fonction.
MOVE A2,PZER ; calcul l'adresse du 1e element.
PUSHJ P,ELEMR ; (dans A5).
MOVN A6,A5 ; adresse negative (a cose des G.C.).
MOVE A5,-1(A5) ; recupere la valeur de BOUND.
MOVN A5,MEM(A5) ; (negate).
PUSH P,A5 ; on la sauve.
DA4: ; et pour chaque element...
PUSH P,A6 ; sauve l'adresse du tablo (negate).
PUSH P,A5 ; sauve l'index courant (negate).
SUB A5,-2(P) ; repasse aux arguments > 0.
PUSHJ P,CRANUM ; j'en cre un nb lisp.
MOVEI A4,(A1) ; prepare larg (pour apply),
MOVE A1,-3(P) ; et la fonction.
PUSHJ P,APPLYL ; applel APPLY des fonctionnelles.
POP P,A5 ; recupere l'index courant.
POP P,A6 ; recupere l'adresse du tablo.
MOVN A7,A6 ; on passe a la forme > 0.
MOVEM A1,(A7) ; charge la valeur.
SUBI A6,1 ; adresse suivante.
AOJL A5,DA4 ; au suivant.
SUB P,[2,,2]
POPJ P,
; ARRAY : DIM STOREQ STORE
; (DIM nom) [1SUBR]
; ramene le plus grand indice possible du tablo nom.
DIM:
MOVE A2,PZER ; calcul de l'adresse du
PUSHJ P,ELEMR ; 1er element de A1.
MOVE A1,-1(A5) ; recup la taille de tablo.
JRST SUB1 ; qu'il faut decrementer.
; (SETQA nom indice val) [FSUBR]
; (SETA nom indice val) [3SUBR]
STOREQ:
UNCONS A1,A1,A2 ;
PUSH P,A1 ; sauve le nom.
UNCONS A2,A1,A2 ; isole l'indice.
PUSH P,A2 ; sauve le reste des arguments.
PUSHJ P,EVAL ; evalue l'indice.
EXCH A1,(P)
PUSHJ P,EVALCA ; evalue la valeur.
POP P,A2 ; recupere l'indice.
POP P,A3 ; recupe le nom.
EXCH A1,A3 ; on se rouve comme pour STORE.
ASTORE: ;;; il faut mieux ne pas appeller
; cette fonction STORE qui est une macro
; de C-mac (j'ai perdu 4 h avec ca).
PUSHJ P,ELEMR ; calcul de l'adresse de cet element.
MOVEM A3,(A5) ; on le force.
MOVEI A1,(A3) ; on ramene la valeur chargee.
POPJ P, ; salut.
; ARRAY : LISTARRAY FILLARRAY ;
; (LISTARRAY nom) [1SUBR]
; ramene une liste contenant tous les elements du tableau
LISTARRAY:
MOVE A2,PZER ; calcul de l'adresse du 1er
PUSHJ P,ELEMR ; elem du tablo.
MOVE A6,-1(A5) ; recup la taille du tablo.
MOVE A6,MEM(A6) ; on prend sa valeur.
CONSL A1,NIL,NIL ; prepare la liste resultat.
PUSH P,A1 ; sauve le debute de cette liste.
LARRY1:
MOVE A2,(A5) ; recupere l'element suivant.
CONSL A2,A2,NIL ; que l'on CONS.
PUTCDR A1,A2 ; on l'accroche.
GETCDR A1,A1 ; avance le pointeur courant.
ADDI A5,1 ; avance dans le tableau.
SOJG A6,LARRY1 ; il reste des elements.
PJRST PD.P ; retour standard.
; (FILLARRAY nom liste) [2SUBR]
; rempli le tablo avec les elements de la liste.
; si liste est (ou devient) atomique, cet atome
; sera force dans tous les elements restants du tablo.
FILLARRAY:
MOVEI A3,(A2) ; sauve la liste -> A3.
MOVE A2,PZER ; calcul de l'adresse du 1er
PUSHJ P,ELEMR ; element du tablo.
MOVE A6,-1(A5) ; recupere la taille du tablo.
MOVE A6,MEM(A6) ; dont on prend la valeur.
FILL1:
JNLIST A3,FILL2 ; ya plus de liste.
UNCONS A3,A4,A3 ; avance dans la liste.
MOVEM A4,(A5) ; charge l'element.
JRST FILL3
FILL2: ; ya plus de liste.
MOVEM A3,(A5) ; on charge donc ce qui reste.
FILL3:
ADDI A5,1 ; avance le pointeur sur le tablo.
SOJG A6,FILL1 ; on boucle pour tous les elements du
; tableau.
POPJ P, ; on ramene le nom du tablo.
; ARRAY : MAPARRAY MAPARRAYQ ;
; (MAPARRAY nom fonction) [2SUBR]
; (MAPARRAYQ nom fonction) [FSUBR]
MAPARQ:
UNCONS A1,A2,A1 ; on doit evaluer fonction
PUSH P,A2 ; sauve le nom
PUSHJ P,EVALCA ; evalue fonction.
POP P,A2 ; recupere le nom.
EXCH A1,A2 ; on se retrouve comme pour MAPARRAY.
MAPARRAY:
PUSH P,A2 ; sauve la fonction.
MOVE A2,PZER ; calcul de l'adresse du 1er
PUSHJ P,ELEMR ; elem du tablo.
MOVE A5,-1(A5) ; recupere la taille du tablo.
MOVN A5,MEM(A5) ; charge sa valeur complementee
; (a cose des g.c.).
PUSH P,A5 ; on la sauve (pour le test de fin).
MAPA1:
PUSH P,A5 ; sauve le nb courant.
SUB A5,-1(P) ; calcul la vraie valeur de l'inndice.
PUSHJ P,CRANUM ; on l'interne.
MOVEI A4,(A1) ; prepare APPLY.
MOVE A1,-2(P)
PUSHJ P,APPLYL ; c'est l'APPLY des fonctionnelles.
POP P,A5
AOJL A5,MAPA1 ; indice suivant.
SUB P,[2,,2] ; repositionne la pile.
POPJ P, ; ramene le nom du tablo.
SUBTTL PREDICATS NUMERIQUES
; NUMB : NUMBP INUMBP FLOATP FIXP
$$NUMB::
PRINTX /12-NUMER.STRINGS/
BIT35: EXP 1 ; BIT NOMBRE PAIR OU IMPAIRE.
; test de type
NUMBP:
JNNUMB A1,FALSE
POPJ P,
INUMBP: ; Teste si l'argument
JNNUMB A1,FALSE ; et un 'petit entier'.
MOVE A5,MEM(A1) ; recup le nb.
JUMPL A5,INMBP1
CAML A5,C.PNUM
JRST FALSE
POPJ P,
INMBP1: ; cas nombre negatif.
MOVN A5,A5
CAMLE A5,C.NNUM
JRST FALSE
POPJ P,
FLOATP:
JNNUMB A1,FALSE ; c'est pas un nb => NIL.
CAML A1,BCNUM ; skip si inumb.
SKIPN MEM+1(A1) ; marque du flottant.
JRST FALSE
POPJ P, ; si vrai ramene l'argument.
FIXP:
JNNUMB A1,FALSE ; c'est pas un nb => NIL.
CAML A1,BCNUM ; skip si inumb.
SKIPN MEM+1(A1) ; marque du flottant.
POPJ P, ; si vrai ramene l'argument.
JRST FALSE ;
; NUMB : LEZP LZP GEZP GZP ZEROP NEROP EVENP ODDP ;
ZEROP:
SKIPA A6,[CAIE A5,0]
NEROP:
MOVE A6,[CAIN A5,0]
PNSUBR:
JNNUMB A1,FALSE
MOVE A5,MEM(A1)
XCT A6
JRST FALSE
POPJ P,
LEZP:
SKIPA A6,[CAILE A5,0]
LZP:
MOVE A6,[CAIL A5,0]
JRST PNSUBR
GEZP:
SKIPA A6,[CAIGE A5,0]
GZP:
MOVE A6,[CAIG A5,0]
JRST PNSUBR
EVENP:
SKIPA A6,[TDNE A5,BIT35]
ODDP:
MOVE A6,[TDNN A5,BIT35]
JRST PNSUBR
; NUMB : EQN NEQN GT GE LT LE DIVP ;
; predicats a 2 arguments
EQN: ; (EQN n1 n2) [SUBR 2]
MOVE A5,MEM(A1) ; recupere la 1ere valeur .
CAME A5,MEM(A2) ; compare a la 2eme.
SETZ A1, ; ramene NIL.
POPJ P, ; dans tous les cas ramene A1.
NEQN: ; (NEQN n1 n2) [SUBR 2]
MOVE A5,MEM(A1) ; recupere la 1ere valeur.
CAMN A5,MEM(A1) ; compare a le 2 eme
SETZ A1, ; ramene NIL.
POPJ P, ; dans tous les cas ramene A1.
; PREDICATS A N ARGUMENTS.
PNNSUB:
JUMPE A4,VPOPJ
GETCAR A4,A1
JNNUMB A1,FALSE
MOVE A5,MEM(A1)
GETCDR A4,A4
JUMPE A4,VPOPJ
PNNSU1:
GETCAR A4,A2
JNNUMB A2,FALSE
MOVE A7,MEM(A2)
XCT A6
JRST FALSE
GETCDR A4,A4
JUMPE A4,VPOPJ
MOVE A5,A7
MOVE A1,A2
JRST PNNSU1
LT:
SKIPA A6,[CAML A5,A7]
LE:
MOVE A6,[CAMLE A5,A7]
JRST PNNSUB
GT:
SKIPA A6,[CAMG A5,A7]
GE:
MOVE A6,[CAMGE A5,A7]
JRST PNNSUB
DIVP: ; [2SUBR]
MOVE A5,MEM(A1) ; val du 1er arg.
IDIV A5,MEM(A2)
JUMPE A6,VPOPJ ; le reste est nul, ramene A1.
JRST FALSE ; sinon ramene NIL.
; NUMB : $PNSUB $LT $LE $GT $GE
; predicats a 2 args pour le compilateur
$PNSUB:
JNNUMB A1,A2POPJ
JNNUMB A2,VPOPJ
MOVE A5,MEM(A1) ; recup la val du 1er.
XCT A8
JRST FALSE
POPJ P, ; ramene le 1er.
$LT::
SKIPA A8,[CAML A5,MEM(A2)]
$LE::
MOVE A8,[CAMLE A5,MEM(A2)]
JRST $PNSUB
$GT::
SKIPA A8,[CAMG A5,MEM(A2)]
$GE::
MOVE A8,[CAMGE A5,MEM(A2)]
JRST $PNSUB
SUBTTL FONCTIONS NUMERIQUES
; NUMB : LENGTH PLENGTH ;
;******************************************************************************
; F O N C T I O N S Q U I C R E E N T U N N O M B R E
;******************************************************************************
; (LENGTH L) - SUBR - LONGEUR DE LA LISTE L (0 SI ATOM).
LENGTH:
SETZ A5, ; RAZ NOMBRE.
LENGT1:
JNLIST A1,CRANUM
GETCDR A1,A1
AOJA A5,LENGT1
; (PLENGTH A) - SUBR - NB DE CARACTERES DE L'ATOME A.
PLENGTH:
CAML A1,BSTRG
JRST PLEN1 ; C'EST LISTE OU CHAINE.
SNATOM A1
SKIPA A6,[POINT 7,MEM+1(A1),6]
PUSHJ P,CONVNB ; C'EST DONC UN NB.
LDB A5,A6 ; RECUP LE NB DE CAR.
JRST CRANUM
PLEN1:
JPLIST A1,CRAZER ; une liste donne 0.
MOVEI A5,2 ; fait un LENGTH intern.
GETCDR A1,A1
PLEN2:
JNLIST A1,CRANUM
GETCDR A1,A1 ; avance dans les CDRs.
AOJA A5,PLEN2
; NUMER : ADD1 SUB1 MINUS ABS SWAP COMPL ;
; S U B R S A R I T H M E T I Q U E S
; SI N N'EST PAS UN NOMBRE, RAMENENT 0.
;
; (ADD1 N) : N+1 ; (SUB1 N) : N-1 ; (MINUS N) : -N
; (ABS N) : /N/ ; (COMPL N) : NOT N ; (SWAP N) : NR,NL.
NUSUBR:
JNNUMB A1,CRAZER
MOVE A5,MEM(A1) ; RECUP NB.
XCT A6
JRST CRANUM
ADD1:
SKIPA A6,[AOJA A5,CRANUM]
SUB1:
MOVE A6,[SOJA A5,CRANUM]
JRST NUSUBR
MINUS:
SKIPA A6,[MOVN A5,A5]
ABS:
MOVE A6,[MOVM A5,A5]
JRST NUSUBR
COMPL:
SKIPA A6,[SETCA A5,]
SWAP:
MOVE A6,[MOVS A5,A5]
JRST NUSUBR
; NUMER : PLUS DIFFER TIMES QUO REM MIN MAX ;
; N N S U B R S A R I T H S
; SAUTENT OTS LES ARGS NON-NUMERIQUES.
NNSUB0:
GETCDR A4,A4
NNSUBR: ;;; GENERAL NSUBR ARITHMETIQUE.
JUMPE A4,CRAZER ; YA PAS DARG.
GETCAR A4,A1 ; RECUP LE 1ER .
JNNUMB A1,NNSUB0 ; C'EST PAS UN NB. ON SAUTE.
MOVE A5,MEM(A1)
NNSUB1:
GETCDR A4,A4
JUMPE A4,CRANUM ; FIN ARGS.
GETCAR A4,A2 ; RECUP LE SUIVANT.
JNNUMB A2,NNSUB1 ; C'EST PAS UN NOMBRE.
MOVE A7,MEM(A2)
XCT A8 ; EXEC LA FONCTION.
JRST NNSUB1
MOVE A5,A7 ; SUCCESS MIN-MAX
JRST NNSUB1
PLUS:
SKIPA A8,[ADD A5,A7]
DIFFER:
MOVE A8,[SUB A5,A7]
JRST NNSUBR
TIMES:
SKIPA A8,[IMUL A5,A7]
QUO:
MOVE A8,[IDIV A5,A7]
JRST NNSUBR
REM:
MOVE A8,[JRST REM1]
JRST NNSUBR
REM1:
IDIV A5,A7
MOVE A5,A6
JRST NNSUB1
MAX:
SKIPA A8,[CAML A5,A7]
MIN:
MOVE A8,[CAMG A5,A7]
JRST NNSUBR
; NUMER COMPILO : SPLUS SDIFFER STIMES SQUO SREM SMAX SMIN ;
; Les memes NSUBRs que precedement mais pour le compilo ;
; elles supposent le 1er arg dans A1, le 2eme dans A2. ;
SPLUS:
$PLUS::
SKIPA A8,[ADD A5,A7]
SDIFFER:
$DIFFER::
MOVE A8,[SUB A5,A7]
JRST SARITN
STIMES:
$TIMES::
SKIPA A8,[IMUL A5,A7]
SQUO:
$QUO::
MOVE A8,[IDIV A5,A7]
JRST SARITN
SMAX:
$MAX::
SKIPA A8,[CAML A5,A7]
SMIN:
$MIN::
MOVE A8,[CAMG A5,A7]
JRST SARITN
SREM:
$REM::
MOVE A8,[JRST SREM1]
JRST SARITN
SREM1:
IDIV A5,A7
MOVE A5,A6
JRST CRANUM
SARITN:
JNNUMB A1,A2POPJ
JNNUMB A2,VPOPJ
MOVE A5,MEM(A1)
MOVE A7,MEM(A2)
XCT A8
JRST CRANUM
MOVE A5,A7
JRST CRANUM
; NUMER : LOGAND LOGOR LOGXOR LOGSHIFT
; (LOGAND n1 n2) [SUBR 2]
LOGAND:
MOVE A5,MEM(A1) ; valeur du 1er operande.
AND A5,MEM(A2) ; effectue le AND.
PJRST CRANUM ; cre un nb entier.
; (LOGOR n1 n2) [SUBR 2]
LOGOR:
MOVE A5,MEM(A1) ; valeur du 1er operande.
IOR A5,MEM(A2) ; OR avec le 2eme operande.
PJRST CRANUM ; cre un nb entier.
; (LOGXOR n1 n2) [SUBR 2]
LOGXOR:
MOVE A5,MEM(A1) ; valeur du 1er operande.
XOR A5,MEM(A2) ; XOR avec le 2eme operande.
PJRST CRANUM ; cre un nb entier.
; (LOGSHIFT n1 n2) [SUBR 2]
LOGSHIFT:
MOVE A5,MEM(A1) ; 1er argument.
MOVE A6,MEM(A2) ; A6 <- nb de decalages.
LSH A5,(A6) ; decalage logique proprement dit.
JRST CRANUM ; cre un nb entier.
; NUMER : BOOLE
; (BOOLE NUMERO N1 ... NN) - NSUBR -
;?!? ----- peut-etre y faodrait transformer en 3subr ...
BOOLT:
SETZ A5, ; 0 POUR NO INCORRECT.
IOR A5,A7 ; 1 A + B
ORCA A5,A7 ; 2 NA + B
ORCM A5,A7 ; 3 A + NB
ORCB A5,A7 ; 4 NA + NB
AND A5,A7 ; 5 A . B
ANDCA A5,A7 ; 6 NA . B
ANDCM A5,A7 ; 7 A . NB
ANDCB A5,A7 ; 8 NA . NB
XOR A5,A7 ; 9 A XOR B
EQV A5,A7 ; 10 A EQV B
LSH A5,(A7) ; 11 LOGSHIFT
ROT A5,(A7) ; 12 ROTSHIFT
ASH A5,(A7) ; 13 ARISHIFT
BOOLE:
JUMPE A4,CRAZER ; YA PAS D'ARGS.
GETCAR A4,A1
GETCDR A4,A4
JNNUMB A1,BOOLE1 ; C'EST PAS UN NUMERO.
MOVE A5,MEM(A1)
CAIL A5,0
CAIL A5,16
BOOLE1:
SKIPA A8,BOOLT
MOVE A8,BOOLT(A5)
JRST NNSUBR
; FLOT : ARERR TFL1
; ARERR : ** non-numeric argument.
; dans -2(L) ya le nom de la fnt, dans A1 l'argument qui deconne.
ARERR:
PUSH P,A1 ; sauve l'argument.
PUSH P,-2(L) ; sauve le nom de la fonction.
PUSHJ P,OUTBUF ; vide le buffer.
POP P,A1 ; recup le nom de la fonction.
PUSHJ P,PRIN1 ; on l'edite.
MOVE A6,[POINT 7,[BYTE (7)↑D26," "," ",":"," "
ASCIZ / ** non-numeric arg : /],6]
PUSHJ P,PRBPN ; edite le libelle.
POP P,A1 ; recup le mauvais argument.
PUSHJ P,PRINT ; on l'edite + RC/LF.
JRST REENTE ;
; Teste le nb dans A1. Suppose dans -2(L) le nom de la fonction
; ya erreur si A1 n'est pas un nb.
; retour direct si le nb est fixe.
; retour skipe si le nb est flottant.
; APPEL : JSP L,TFL1
TFL1:
JNNUMB A1,ARERR ; A1 n'est meme pas un nb !
MOVE A5,MEM(A1) ; recup sa valeur.
CAML A1,BCNUM ; c'est un nb cree ?
SKIPN MEM+1(A1) ; test indic float.
JRST (L) ; retour fixe
JRST 1(L) ; retour float.
; FLOT : TFL2 FIX FLOAT
; TFL2 : teste A1 et A2 , ramene les 2 valeurs respectives
; dans A5 et A6. effectue toutes les conversions necessaires,
; le flottant ayant la priorite.
; retour direct si fix,
; retour DOUBLE skipe si float.
TFL2:
JNNUMB A1,ARERR ; 1er arg /= nb.
MOVE A5,MEM(A1) ; recup sa valeur.
CAML A1,BCNUM ; nb fixe ou
SKIPN MEM+1(A1) ; cree fixe ?
JRST TFL25 ; ouaip : voir le 2eme.
JNNUMB A2,TFL29 ; le 2eme n'est pas un nb.
MOVE A6,MEM(A2) ; recup sa valeur.
CAML A2,BCNUM ; si petit entier fixe ou
SKIPN MEM+1(A2) ; cree fixe ?
FLTR A6,A6 ; (FLOAT A2).
JRST 2(L) ; les 2 sont floats.
TFL25: ; le 1er est fixe.
JNNUMB A2,TFL29 ; ca va pas.
MOVE A6,MEM(A2) ; recup la valeur du nb.
CAML A2,BCNUM ; petit num fixe ou
SKIPN MEM+1(A2) ; fixe cree ?
JRST (L) ; rentre les 2 sont fixes.
FLTR A5,A5 ; (FLOAT A1).
JRST 2(L) ; les 2 sont floats.
TFL29: ; erreur 2eme arg.
MOVEI A1,(A2)
JRST ARERR
; CONVERSIONS : FIX + FLOAT
EXP A.FIX ; adresse de l'atome FIX.
FIX:
JSP L,TFL1 ; teste l'argument.
POPJ P, ; argument deja fix.
FIXR A5,A5 ; conversion.
JRST CRANUM ; creation fixe.
EXP A.FLO ; adresse de l'atome FLOAT.
FLOAT:
JSP L,TFL1 ; teste l'argument.
JRST FLOAT1 ; il est FIX.
POPJ P, ; il etait deja float.
FLOAT1:
FLTR A5,A5 ; conversion.
JRST CRAFLT ; vers creation flottante.
; FLOT : FADD1 FSUB1 FADD FSUB FTIM
; (1+ N) [1SUBR]
EXP A.FAD1 ; nom de la fnt TFL1 doit suivre.
FADD1:
JSP L,TFL1 ; teste A1
AOJA A5,CRANUM ; fixe.
FADR A5,[1.0] ; float.
JRST CRAFLT
; (1- N) [1SUUBR]
EXP A.FSB1
FSUB1:
JSP L,TFL1 ; teste A1.
SOJA A5,CRANUM ; fixe.
FSBR A5,[1.0] ; FLOAT.
JRST CRAFLT
; (+ n1 n2) [2SUBR]
EXP A.FADD
FADD:
JSP L,TFL2 ; teste A1 et A2.
ADD A5,A6 ; fixe.
JRST CRANUM
FADR A5,A6 ; float double skip.
JRST CRAFLT
; (- n1 n2) [2SUBR]
EXP A.FSUB
FSUB:
JSP L,TFL2
SUB A5,A6
JRST CRANUM
FSBR A5,A6
JRST CRAFLT
; (* n1 n2) [2SUBR]
EXP A.FTIM
FTIM:
JSP L,TFL2
IMUL A5,A6
JRST CRANUM
FMPR A5,A6
JRST CRAFLT
; FLOT : FQUO FREM PUISS
; (/ n1 n2) [2SUBR]
EXP A.FQUO
FQUO:
JSP L,TFL2
IDIV A5,A6
JRST CRANUM
FDVR A5,A6
JRST CRAFLT
; (\ n1 n2) [2SUBR]
EXP A.FREM ; adresse de l'atome \
FREM:
JSP L,TFL2 ; teste les 2 ARGUMENTS.
IDIV A5,A6 ; si fix.
JRST FREM1
FDVL A5,A6 ; si float.
MOVE A5,A6 ; recupere le reste.
JRST CRAFLT ; vers creation flottante.
FREM1: ; suite fixe.
MOVE A5,A6 ; recupere le reste.
JRST CRANUM ; vers creation fixe.
; (** N1 N2) N1 PUISSANCE N2 [2SUBR]
EXP A.PUIS ; adresse de l'atome **
PUISS:
JSP L,TFL2 ; teste des args.
JRST PUISS1 ; c'est 2 entiers.
JFCL
PUSH P,[CRAFLT] ; c'est 2 flottants.
MOVEI A7,EXP3.0## ; adresse de la routine ** float.
JRST PUISS2
PUISS1:
PUSH P,[CRANUM] ; prepare le retour fixe.
MOVEI A7,EXP1.0## ; adresse de la routine fixe.
PUISS2:
PUSH P,RG ; sauveles registres indispensables.
PUSH P,STRG
PUSH P,NUMB
PUSH P,FREE
MOVE RG,A5 ; prepare le 1er arg
MOVE A1,A6 ; prepare le 2eme arg.
PUSHJ P,(A7) ; lance la routine (resul -> R0).
MOVE A5,RG ; recup le result
POP P,FREE ; rsetore les registres.
POP P,NUMB
POP P,STRG
POP P,RG
POPJ P, ; on tombe sur CRANUM ou CRAFLT.
; FLOT : FEQ FNEQ FLE FLT FGE FGT
; Predicats mixtes : = # > >= < <=
EXP A.FEQ ; adresse de l'atome =
FEQ:
JSP L,TFL2 ; test et conversion des 2 args.
REPEAT 2,<JFCL> ; si FIXP : meme test.
CAME A5,A6 ; test d'egalite.
SETZ A1, ; ramene NIL
POPJ P, ; ramene A1 (le 1er arg).
EXP A.FNEQ ; adresse de l'atome #
FNEQ:
JSP L,TFL2 ; test et conversion des 2 args.
REPEAT 2,<JFCL> ; si FIXP : meme test.
CAMN A5,A6 ; test d'inegalite.
SETZ A1, ; ramene NIL.
POPJ P, ; ramene A1 (le 1er arg).
EXP A.FLE ; adresse de l'atome <=
FLE:
JSP L,TFL2 ; test et conversion des 2 args.
REPEAT 2,<JFCL> ; si FIXP : meme test.
CAMLE A5,A6 ; test > ou =.
SETZ A1, ; ramene NIL.
POPJ P, ; ramene A1 (le 1er arg).
EXP A.FLT ; adresse de l'atome <
FLT:
JSP L,TFL2 ; test et conversion des 2 args.
REPEAT 2,<JFCL> ; si FIXP : meme test.
CAML A5,A6 ; test > .
SETZ A1, ; ramene NIL.
POPJ P, ; ramene A1 (le 1er arg).
EXP A.FGE ; adresse de l'atome >=
FGE:
JSP L,TFL2 ; test et conversion des 2 args.
REPEAT 2,<JFCL> ; si FIXP : meme test.
CAMGE A5,A6 ; test >=
SETZ A1, ; ramene NIL.
POPJ P, ; ramene A1 (le 1er arg).
EXP A.FGT ; adresse de l'atome >
FGT:
JSP L,TFL2 ; test et conversion des 2 args.
REPEAT 2,<JFCL> ; si FIXP : meme test.
CAMG A5,A6 ; test >
SETZ A1, ; ramene NIL.
POPJ P, ; ramene A1 (le 1er arg).
; FORT : APFORT FSQRT FSIN FCOS
; appel d'une fonction FORTRAN a 1 argument.
; @ de lancement dans A6.
APFORT:
PUSH P,[CRAFLT] ; prepare le retour flottant.
PUSH P,RG
PUSH P,A2
PUSH P,STRG
PUSH P,NUMB
PUSH P,FREE
ADDI A1,MEM
MOVEI LAF,(A7) ; positionne sur la liste des args.
HRRM A1,(LAF) ; force le 1er argument.
PUSHJ P,(A6) ; appel effectif de la fnt FORTRAN.
MOVE A5,RG ; FORTRAN ramenela valeur dans R0.
POP P,FREE
POP P,NUMB
POP P,STRG
POP P,A2
POP P,RG
SETZB A3,A4 ; on sait jamais ca qu'a pu y mettre
; FORTRAN, et c'est pas bon pour le G.C.
POPJ P, ; cre la valeur ramenee (CRAFLT ou CRANUM).
; (SQRT float) [1SUBR]
FSQRT:
MOVEI A6,SQRT## ; adresse de SQRT.
MOVEI A7,APFRL1 ; 1 arg reel.
JRST APFORT ; vers lancement FORTRAN.
; (SIN rad) [1SUBR]
FSIN:
MOVEI A6,SIN## ; adresse de SIN.
MOVEI A7,APFRL1 ; 1 arg reel.
JRST APFORT ; vers lancement FORTRAN.
; FORT : FATAN FEXP FLOG FLOG10 RANDOM
; (COS rad) [1SUBR]
FCOS:
MOVEI A6,COS## ; adresse de COS.
MOVEI A7,APFRL1 ; 1 arg reel.
JRST APFORT ; vers lancement FORTRAN.
; (ATAN n) [1SUBR]
FATAN:
MOVEI A6,ATAN## ; adresse de ATAN.
MOVEI A7,APFRL1 ; 1 arg reel.
JRST APFORT ; vers lancement FORTRAN.
; (EXP e) [1SUBR]
FEXP:
MOVEI A6,EXP## ; adresse de EXP.
MOVEI A7,APFRL1 ; 1 arg reel.
JRST APFORT ; vers lancement FORTRAN.
; (LOG e) [1SUBR]
FLOG:
MOVEI A6,ALOG## ; adresse de LOG.
MOVEI A7,APFRL1 ; 1 arg reel.
JRST APFORT ; vers lancement FORTRAN.
; (LOG10 n) [1SUBR]
FLOG10:
MOVEI A6,ALOG10## ; adresse de LOG10.
MOVEI A7,APFRL1 ; 1 arg reel.
JRST APFORT ; vers lancement FORTRAN.
; (RANDOM) [0SUBR]
RANDOM:
MOVEI A6,RAN## ; adresse de RAN.
MOVEI A7,APFRL0 ; pas d'arg.
JRST APFORT ; vers lancement FORTRAN.
; DAC : Toutes les fonctions sur le DAC.
; (DACSET n) [SUBR 1] initialise le DAC.
IFN %DAC,<
ADACSET:
MOVEI A6,DACSET##
MOVEI A7,APFRL1
JRST APFORT
>
; (DACCHN n) [SUBR 1] selection du cannal
; 00 pas, 01 mono, 10 stereo, 11 quadri
IFN %DAC,<
ADACCHN:
MOVEI A6,DACCHN##
MOVEI A7,APFRL1
JRST APFORT
>
; (DACFIL n) [SUBR 1] filtres 10000 ou 4000
IFN %DAC,<
ADACFIL:
MOVEI A6,DACFIL##
MOVEI A7,APFRL1
JRST APFORT
>
; (DACRAT n) [SUBR 1] rate (e.g. 10000)
IFN %DAC,<
ADACRAT:
MOVEI A6,DACRAT##
MOVEI A7,APFRL1
JRST APFORT
>
; (DACS adr val) [SUBR 2] force une val dans le buffer du DAC.
IFN %DAC,<
ADACS:
MOVE A5,MEM(A1) ; A5 :- val de l'adresse.
MOVE A6,MEM(A2) ; A6 :- la val a charger.
MOVEM A6,BDAC(A5) ; ce qui est fait.
POPJ P,
>
; (DACOUT n) [SUBR 1] vide n elements du tableau.
IFN %DAC,<
ADACOUT:
MOVEI A6,DACOUT##
MOVEI A7,APFRL3 ; ya 3 args en realite.
PUSHJ P,APFORT
MOVE A5,DACR ; ramene le code retour.
JRST CRANUM ; convertit en entier.
>
SUBTTL FONCTIONS SUR LES CHAINES
; STRG : STRING MAKLIST STRINGP NULLSTRP
;******************************************************************************
; F O N C T I O N S S U R L E S C H A I N E S
; STRING MAKLIST STRINGP NULLSTRP EQSTRING
; STRINGL CONCAT REVERSTR DUPL READSTR
;******************************************************************************
; (STRING S) - SUBR -
STRGF:
JNSTRG A1,STRGFC
POPJ P, ; C'EST DEJA UNE CHAINE.
STRGFC: ; CONVERSION ATOME-CHAINE.
JPNIL A1,CRASTN ; C'EST NIL.
JPLIST A1,CRASTR ; C'EST UNE LISTE : on suppose
; donc que c'est une liste mono-caracteres.
CONSL A4,A1,NIL ; POUR EXPLODE NSUBR.
PUSHJ P,EXPLODE
PJRST CRASTR
; (MAKLIST S) - SUBR -
MLSTRG:
SKSTRG A1
PUSHJ P,STRGFC
GETCDR A1,A1 ; RECUP LISTE DE CARACT.
POPJ P,
; (STRINGP S) - SUBR -
STRINP:
JNSTRG A1,FALSE
POPJ P,
; (NULLSTRP S) - SUBR -
NSTRGP:
SKSTRG A1
PUSHJ P,STRGFC
GETCDR A1,A2 ; RECUP LA LISTE DES CARACTERES.
JUMPN A2,FALSE
POPJ P,
; STRG : EQSTRING STRINGL CONCAT
; (EQSTRING STR1 STR2) - SUBR -
EQSTRG:
SKSTRG A1
JRST [PUSH P,A2
PUSHJ P,STRGFC
POP P,A2
JRST .+1]
SKSTRG A2
JRST [PUSH P,A1
MOVEI A1,(A2)
PUSHJ P,STRGFC
POP P,A2
JRST EQ]
JRST EQ
; (STRINGL STR) - SUBR -
STRGLE:
PUSH P,[LENGTH]
PJRST MLSTRG
; (CONCAT STR1 ... STRN) - NSUBR -
CONCAT:
JPNIL A4,CRASTN ; YA PAS D'ARG => "" .
CONSL A3,NIL,NIL ; PREP CHAINE RESULT
PUSH P,A3 ; ON LA SAUVE.
CONCT1:
UNCONS A4,A1,A4 ; ARG SUIV.
SAVR A3,A4 ; SAUVE LAST ET RESTE.
PUSHJ P,MLSTRG ; CONVERSION EN LISTE DE CARACTERES.
BABYL A4,A3 ; RECUP RESTE ET LAST
JPNIL A1,CONCT3 ; C'EST LA CHAINE VIDE.
CONCT2:
HLLZ A2,MEM(A1) ; CARACTERES SUIVANT.
CONSL A2,,
ADLIST A3,A2 ; ON L'AJOUTE.
GETCDR A1,A1 ; AVANCE DANS LA CHAINE.
JUMPN A1,CONCT2 ; YEN A ENCOEE.
CONCT3:
JNNIL A4,CONCT1 ; YA ENCORE DES ARGS.
PJRST CRPSTR ; RECUP LA CHAINE EN PILE.
; STRG : REVERSTR DUPL
; (REVERSTR STR) - SUBR -
REVSTR:
PUSHJ P,MLSTRG ; CONVERSION A1 EN LISTE DE CARACT.
SETZ A2, ; 2EME ARG DE REVERSE.
PUSHJ P,REVERSE
PJRST CRASTR ; CREATION DE LA NOUVELLE CHAINE.
; (DUPL STR N) - SUBR -
$DUPL:: ; (DUPL str) [1SUBR] compilateur
SETZ A2,
DUPL:
PUSH P,A2 ; SAUVE N.
PUSHJ P,MLSTRG ; CONVERTIT A1 EN LISTE DE CARACT.
POP P,A2 ; RECUP N.
JPNIL A1,CRASTN ; C'EST NIL => "".
SKNUMB A2
SKIPA A8,[1] ; 1 FOIS PAR DEFAUT.
MOVE A8,MEM(A2)
JUMPLE A8,CRASTN
CONSL A4,NIL,NIL ; PREP LISTE RESULTAT.
PUSH P,A4 ; PREP LISTE RESULT.
JRST DUPL3
DUPL1:
MOVEI A2,(A1)
DUPL2:
HLLZ A3,MEM(A2) ; GETCAR A2,A3 ; MOVS A3,A3
CONSL A3,,
ADLIST A4,A3 ; ON L'AJOUTE.
GETCDR A2,A2 ; AVANCE DANS LA CHAINE.
JNNIL A2,DUPL2
DUPL3:
SOJGE A8,DUPL1 ; ON DUPLIQUE ENCORE.
PJRST CRPSTR ; RECUP LA LISTE EN PILE.
; STRG : SUBSTRING
; (SUBSTRING STR BEG END) - SUBR -
; OK y fo mettre les commentaires
SUBSTRING:
SAVR A3,A2 ; SAUV END PUIS BEG.
SKSTRG A1
PUSHJ P,STRGFC ; CONVERTIT LA CHAINE.
POP P,A2
SKNUMB A2
SKIPA A5,[1] ; VAL/DEF.
MOVE A5,MEM(A2)
SKIPG A5
MOVEI A5,1 ; IL ETAIT NEGATIF.
POP P,A3
SKNUMB A3
SKIPA A6,MAXPOS ; VAL/DEF END.
MOVE A6,MEM(A3)
CAILE A5,(A6)
PJRST CRASTN ; BEG > END => "".
MOVEI A8,1
SBSTR1:
GETCDR A1,A1 ;;; AVANCE JUSQU'A BEG
JPNIL A1,CRASTN
CAIGE A8,(A5)
AOJA A8,SBSTR1
CONSL A3,NIL,NIL ; PREP LISTE RESULT.
PUSH P,A3 ; ON LA SAUVE.
SBSTR2:
HLLZ A4,MEM(A1) ; CARACTERE SUIVANT.
CONSL A4,,
ADLIST A3,A4
GETCDR A1,A1
JPNIL A1,CRPSTR ; LA CHAINE EST FINIE.
CAIGE A8,(A6)
AOJA A8,SBSTR2 ; ILEN FO ENCORE.
PJRST CRPSTR ; RECUP LA LISTE EN PILE.
; STRG : TRANSLATE
; (TRANSLATE STR1 STR2 STR3) - SUBR -
; RAMENE UNE COPIE DE STR1 EN Y REMPLACANT LES CARACTERES
; INCLUS DANS STR2 PAR LEURS HOMOLOGUES DANS STR3.
; SI YA PAS D'HOMOLOGUE, LE CARACT EST DELETE.
TRANSLATE:
PUSH P,A2 ; CONVERSION DES 3 ARGS.
PUSH P,A3
SKSTRG A1
PUSHJ P,STRGFC
GETCDR A1,A1 ; RECUP LES CARCAT.
EXCH A1,-1(P)
SKSTRG A1
PUSHJ P,STRGFC
GETCDR A1,A1
EXCH A1,(P)
SKSTRG A1
PUSHJ P,STRGFC
POP P,A2
POP P,A3
EXCH A1,A3 ; OUF...
JPNIL A1,CRASTN ; VIDE C'EST VIDE.
CONSL A4,NIL,NIL ; PREP LISTE RESULT.
PUSH P,A4 ; ON LA SAUVE.
RPLC1:
GETCAR A1,A5 ; CARACT SUIV.
SETZ A8, ; RAZ INDEX DANS A2 ET A3.
MOVE A6,A2
RPLC2:
GETCAR A6,A7 ; AU SUIVANT DE A2.
CAMN A5,A7
JRST RPLC6 ; IL EXISTE !
ADDI A8,1
GETCDR A6,A6 ; AVAMCE DANS A2
JUMPN A6,RPLC2 ; CA CONTINUE.
RPLC4:
CONSL A5,A5,NIL
ADLIST A4,A5
RPLC5:
GETCDR A1,A1 ; AVANCE DANS A1
JNNIL A1,RPLC1 ; C'EST PAS FINI.
PJRST CRPSTR ; RECUP CHAINE EN PILE.
RPLC6:
SKIPA A6,A3 ; prepare str3.
RPLC7:
GETCDR A6,A6
SOJG A8,RPLC7 ; (NTH A8 (MAKLIST A3))
GETCAR A6,A5
JUMPN A5,RPLC4 ; YA UN HOMOLOGUE.
JRST RPLC5 ; YEN A PAS.
; STRG : READSTR
; (READSTR) - SUBR -
READST:
CONSL A2,NIL,NIL ; PREPARE LISTE RESULTAT.
PUSH P,A2
MOVEM A2,TEMP$L ; SAUVE LAST.
READS1:
PUSHJ P,@INCHAR
SKIPN TABCAR(A7) ; TYPE DU CARACTERE.
JRST READS1 ; SAUTE TOUS LES BREAKS.
READS2:
PUSHJ P,CRACAR ; CRE L'ATOME MONO CARACTERE.
CONSL A1,A1,NIL
MOVE A2,TEMP$L
PUTCDR A2,A1 ; AJOUTE A LA LISTE.
MOVEM A1,TEMP$L
PUSHJ P,@INCHAR ; CARACTERE SUIVANT.
SKIPE TABCAR(A7) ; TYPE DU CARACTERE.
JRST READS2 ; CONTINUE C'EST PAS UN BREAK.
PJRST CRPSTR ; CREATION CHAINE EN PILE.
SUBTTL FONCTIONS SYSTEMES.
; SYS : LOC VAG PATCH ST1CHR
$$SYS::
PRINTX /13-STATUS/
; (LOC S NIL/T) [2SUBR]
; SI NIL ramene l'adresse de l'objet lisp (i.e. son INdex ds MEM)
; si T ramene l'adresse reelle
$LOC:: ; (LOC s) [1SUBR] compilateur
SETZ A2,
LOC:
MOVE A5,A1
JUMPE A2,CRANUM ; ramene l'index
ADDI A5,MEM ; ajoute la base des objets LISP.
PJRST CRANUM
; (VAG n NIL/T) [2SUBR]
; si = NIL ramene l'objet LISP d'aresse n (index dans MEM).
; si = t ramene l'objet a l'adresse reelle N.
VAG:
JUMPN A2,VAG1
;$VAG:: ; c'est mieux dans tous les cas open.
MOVE A1,MEM(A1)
POPJ P,
VAG1:
MOVE A1,(A1)
POPJ P,
; (PATCH adress value) [2SUBR]
; permet des patches dans le HIGSEG.
; Cette fonction ne fait aucun test actuellement.
PATCH:
SETZ A7, ; write privilege.
SETUWP A7,
PJRST FALSE
MOVE A6,MEM(A1) ; A6 <- l'adresse.
MOVE A5,MEM(A2) ; A5 <- la valeur.
MOVEM A5,(A6) ; on change.
MOVSI A7,400000 ; bit 35 on : wite-protect.
SETUWP A7, ;
PJRST FALSE
POPJ P, ; on ramene le A1 du debut.
; MET DANS A7 LE 1ER CARACTERE DU PNAME DE A2
; execute un skip return si OK, si erreur normal return.
ST1CHR:
CAML A2,BSTRG ; # LITATOM
JRST [CAML A2,BLIST
POPJ P, ; C'EST UNE LISTE.
GETCDR A2,A2
GETCAR A2,A2 ; A2 <- 1ER CARACTERE DE LA CHAINE.
JRST ST1CHR]
PUSH P,A6 ; SAUVE L'@ pour les STATUS.
MOVE A7,MEM(A2) ; POUR CONVB0
SNATOM A2
SKIPA A6,[POINT 7,MEM+1(A2),6]
PUSHJ P,CONVB0
LDB A7,A6
SOJN A7,P.P ; PAS MONO-CARACTERE.
ILDB A7,A6 ; RECUP LE 1ER CARACTERE.
POP P,A6 ; RECUP L'@
AOS (P) ; prepare le SKIP return.
POPJ P, ; VOILA.
; SYS : OTODE TIME
; OTODE : convertit A7 en 2 digits decimaux
; dans la caine de pointeur A6 et de count A5.
; appel : JSP L,OTODE
OTODE:
IDIVI A7,↑D10
ADDI A7,"0" ; conversion des poids forts.
IDPB A7,A6
ADDI A5,1 ; mise a jour du nb de carctes.
ADDI A8,"0" ; conversion des poids faibles du nb.
OTODC: ;;; force le caractere dans A8.
IDPB A8,A6
ADDI A5,1
JRST (L)
; (TIME) [0SUBR]
ATIME:
JSP L,RZPNAME
MSTIME A7, ; demande du temps em ms.
IDIVI A7,↑D1000
IDIVI A7,↑D60
PUSH P,A8 ; sauve les secondes.
IDIVI A7,↑D60
PUSH P,A8 ; sauve les minutes.
JSP L,OTODE
MOVEI A8,":"
JSP L,OTODC
POP P,A7
JSP L,OTODE
MOVEI A8,":"
JSP L,OTODC
POP P,A7
TIMEND:
JSP L,OTODE ; edite le dernier nb.
DPB A5,[POINT 7,PNAME,6] ; force le nb de caracteres.
PJRST CRATOM ; vers creatiom de cet atome.
; SYS : DATE VERSION
; (DATE) [0SUBR] sous la forme dd-mm-yy
ADATE:
JSP L,RZPNAME
DATE A7,
IDIVI A7,↑D31
PUSH P,A7 ; sauve les mois
AOS A7,A8 ; les jours commencent a 1
CAIG A7,↑D9 ; ya 2 chiffres ?
ADDI A7,7760*↑D10 ; force un espace.
JSP L,OTODE ; edite les jours.
POP P,A7 ; recupere le mois.
IDIVI A7,↑D12 ; ya 12 mois ds l'annee he ouai.
MOVE A8,DATAB(A8) ; prend le litteral.
JSP L,OTODC ; edite les 5 caractres.
LSH A8,-7
JUMPN A8,.-2
MOVEI A7,↑D64(A7) ; calcul l'annee (a partir dd 1964)
JRST TIMEND
DATAB: ; ca ferait un joli test de IQ !
"-naJ-"
"-beF-"
"-raM-"
"-rpA-"
"-yaM-"
"-nuJ-"
"-luJ-"
"-guA-"
"-peS-"
"-tcO-"
"-voN-"
"-ceD-"
; (VERSION) [0SUBR]
; ramene le numero de version de l'interprete.
VERSION:
MOVE A5,.JBVER ; recup le numero de version,
PJRST CRANUM ; on l'interne.
; STAT : STATB STATC STATW
; STATB: TRAITEMENT DES BITS DU R.G.
STATB:
GETCDR A4,A4 ; ARG SUIVANT.
JUMPE A4,VPOPJ ; FIN LARG.
GETCAR A4,A1
JNNUMB A1,ERST ; C'EST PAS UN NUMERO.
MOVE A6,MEM(A1) ; RECUP NB.
JUMPL A6,ERST ; SI NB 35<NB<0
CAIL A6,44 ; ERREUR STATUS.
JRST ERST
MOVEI A5,1 ; PREPARE LE BIT.
LSH A5,(A6) ; ON LE METS A LA BONNE PLACE.
XCT A7 ; ON EXECUTE LA FONCTION.
JRST STATB
JRST FALSE ; (POUR TESBIT).
; STATC: TRAITEMENT DES CARACTERES SPECIAUX.
STATC:
JUMPE A2,STATC1 ; VERS GET ONLY.
PUSHJ P,ST1CHR ; 1ER CARACTERE DE A2
PJRST ERST ; c'est pas mono-caractere.
MOVEM A7,(A6) ; SET CAR.
STATC1:
MOVE A7,(A6) ; GET CAR.
JRST CRACAR
; STATW: TRAITEMENT FULL WORD NUMERIQUES.
; A6 <- @ ; A7 <- LIMINF ; A8 <- LIMSUP.
MAXPOS: OCT 377777777777 ; NB POSITIF MAXI.
MINNEG: OCT 400000000000 ; NB NEGATIF MIN.
STATWS: ; SANS LIMITE.
SKIPA A7,MINNEG
STATWP: ; LIMITE POSITIVES.
SETZ A7,
MOVE A8,MAXPOS
STATW: ; LIMITES DONNEES.
JUMPE A2,STATWG ; GET ONLY.
JNNUMB A2,ERST ; C'EST PAS UN NB.
MOVE A5,MEM(A2) ; RECUP NB.
CAML A5,A7
CAMLE A5,A8
JRST ERST ; OUT OF BOUNDS.
MOVEM A5,(A6) ; SET WORD.
STATWG:
MOVE A5,(A6) ; GET WORD.
JRST CRANUM
; STAT : STATT STATUS DE 0 a 29
; STATT : TRAITEMENT DU BIT DE TRACE.
STATT:
GETCDR A4,A4 ; AU SUIVANT.
JUMPE A4,VPOPJ ; C'EST FINI.
GETCAR A4,A6
JNATOM A6,ERST ; Y FO UN LITTERAL.
HLRZ A8,MEM+4(A6)
XCT A7 ; METS OU ENLEVE LE BIT.
HRLM A8,MEM+4(A6) ; SET INDIC.
JRST STATT
;
STA0: ;*** R.G.
MOVEI A6,RG
JRST STATWP
STA1: ;*** SETBIT.
SKIPA A7,[TDO RG,A5]
STA2: ;*** CLRBIT.
MOVE A7,[TDZ RG,A5]
JRST STATB
STA3: ;*** NEGBIT.
SKIPA A7,[TDC RG,A5]
STA4: ;*** TESBIT.
MOVE A7,[TDNE RG,A5]
JRST STATB
STA5: ;*** IBASE.
; [PAT] interpretation des bases
; puissance de 2.
MOVEI A6,IBASE ; (pour STATWG).
JUMPE A2,STATWG ; GET only.
JNNUMB A2,ERST ; c'est pas un nombre.
MOVE A5,MEM(A2) ; recup sa valeur.
CAIL A5,2 ; test de validite de base.
CAILE A5,20 ; de binaire a hexa.
JRST ERST ; c'est pas bien serieux ...
MOVEM A5,IBASE
MOVE A6,[IMUL A5,IBASE] ; prepare le IBASEX standard.
MOVEM A6,IBASEX
; rech si A5 est une puissance de 2
; theo : X = 2**N si X and (-X) = X.
MOVN A6,A5 ; A6 <- - A5.
AND A6,A5 ; A6 <- IBASE and (- IBASE).
CAME A6,A5 ; si A6=A5, ibase est une puiss. de 2.
JRST CRANUM ; c'etait pas le cas.
; calcul du nb de decalages.
SETO A7,
STA51: ADDI A7,1
LSH A6,-1 ; tant qu'on tombe pas sur le bit.
JUMPN A6,STA51
HRLI A7,(LSH A5,) ; on forme donc LSH A5,n
MOVEM A7,IBASEX ; que l'on range.
MOVEI A1,(A2) ; ramene la nouvelle base N.
POPJ P,
STA6: ;*** OBASE.
MOVEI A6,OBASE
MOVEI A7,2 ; LIM INF (BINAIRE).
MOVEI A8,20 ; LIM SUP (HEXA).
JRST STATW
STA7: ;*** LEFT MARGIN.
MOVEI A6,PRMARG
JRST STA91
STA8: ;*** POBUFOUT.
MOVEI A6,BUFOUP
JRST STA91
STA9: ;*** RIGTH MARGIN.
MOVEI A6,BUFOUL
SKIPA A7,[22] ; MINI LENGTN PNAME.
STA91:
SETZ A7,
MOVEI A8,170
JRST STATW
STA10: JRST ERST
STA11: ;*** PREFOR
MOVEI A6,PREFOR
PUSHJ P,STATC
MOVE A6,PREFOR
DPB A6,[POINT 7,PINTER,6]
POPJ P,
STA12: ;*** PREFTO.
MOVEI A6,PREFTO
JRST STATC
STA13: ;*** PREFPR.
MOVEI A6,PREFPR
JRST STATC
STA14: ;*** QUOTEC.
MOVEI A6,QUOTEC
JRST STATC
STA15: ;*** COMMENT.
MOVEI A6,COMMENT
JRST STATC
STA16: ;*** STRING.
MOVEI A6,CSTRIN
JRST STATC
STA17: ;*** TYPECHAR.
PUSHJ P,ST1CHR ; 1ER CARACTERE DU PNAME
PJRST ERST ; c'est pas mono-caractere.
JUMPE A3,STA171 ; VERS GET ONLY.
JNNUMB A3,ERST ; LE 3EME ARG DOIT ETRE UN NB.
MOVE A6,MEM(A3) ; RECUP NB.
HRRM A6,TABCAR(A7) ; SET TYPECHAR.
STA171:
HRRZ A5,TABCAR(A7) ; GET TYPECHAR.
JRST CRANUM.
STA18: ;*** MACHAR.
PUSHJ P,ST1CHR ; 1ER CARACTERE DU PNAME DE A2.
PJRST ERST ; c'est pas mono-caractere.
JUMPE A3,STA181 ; VERS GET ONLY.
HRLM A3,TABCAR(A7)
STA181:
HLRZ A1,TABCAR(A7) ; GET MACRO CHAR.
POPJ P,
STA19: ;*** DELCHAR.
PUSHJ P,ST1CHR ; 1ER CARACTERE DU PNAME DE A2.
PJRST ERST ; c'est pas monocaractere.
SETZ A3,
HRLM A3,TABCAR(A7)
POPJ P,
STA20: ;*** LASTREAD.
MOVE A1,LASTRD
POPJ P,
STA21: ;*** G.C.
PUSHJ P,GARBCY
STA22: ;*** LENGTH FREE.
MOVE A5,GARBF ; recup le nb de doublets liberes.
PJRST CRANUM ; que l'on interne.
STA23: ;*** STEP G.C.
MOVEI A6,GARBC
JRST STATWS
STA24: ;*** LIMIT G.C.
MOVEI A6,GARBL
JRST STATWP
STA25:
JRST ERST
STA26: ;*** GENSYM COUNTER.
MOVEI A6,GENSYC
JRST STATWS
STA27:
JRST ERST
STA28: ;*** TRACE FUNCTIONS.
SKIPA A7,[TRO A8,BITRAC]
STA29: ;*** UNTRACE FUNCTIONS.
MOVE A7,[TRZ A8,BITRAC]
JRST STATT
; STATUS de 30 a 39 ;
STA30:
JRST ERST
; (SWITCH) [0SUBR]
SWITCH:
STA31: ;*** SWITCH
SWITCH A5,
JRST CRANUM
; (LIGTHS n) [1SUBR]
LIGHTS:
STA32: ;*** LIGHTS
MOVE A5,MEM(A1)
LIGHTS A5,
POPJ P,
STA33:
JRST ERST
; (GETTAB n1 n2) [2SUBR]
GETTAB:
STA34: ;*** GETTAB
HRL A5,MEM(A1)
HRR A5,MEM(A2)
GETTAB A5,
JRST FALSE
JRST CRANUM
; (RUNTIME) [0SUBR]
RUNTIME:
STA35: ;*** RUNTIME
RUNTIM A5,
JRST CRANUM
; (DAYTIME) [0SUBR]
DAYTIME:
STA36: ;*** DAYTIME
MOVE A5,PNJOB
MSTIME A5,
JRST CRANUM
STA37: ;*** DATE
DATE A5,
JRST CRANUM
; (PJOB) [0SUBR]
PJOB:
STA38: ;*** PJOB.
MOVE A5,PNJOB
JRST CRANUM
; (GETPPN) [0SUBR]
GETPPN:
STA39: ;*** GETPPN.
GETPPN A5,
JFCL
PPNVAL: ; creation d'un PPN lisp.
TLNE A5,777740
TRNN A5,777740
JRST PPNOCT ; petits nombres.
TLNE A5,770000 ; retablissement des bits 4000000
TLO A5,400000
TRNE A5,770000
TRO A5,400000
MOVEM A5,TEMP$T
HLLZ A5,A5 ; pg.
PUSHJ P,CVSAT ; en atome.
PUSH P,A1 ; on e sauve.
HRLZ A5,TEMP$T ; pj.
PUSHJ P,CVSAT ; en atome.
POP P,A2 ; recup le pg.
PJRST XCONS ; creation (pg . pj).
PPNOCT:
MOVEM A5,TEMP$T ; sauv tout le nombre.
HLRZ A5,A5 ; pg.
PUSHJ P,CRANUM ; on l'interne.
PUSH P,A1 ; sauve la val.
HRRZ A5,TEMP$T ; recup pj.
PUSHJ P,CRANUM ; on l'interne.
POP P,A2 ; recup pg.
PJRST XCONS ; creation (pg . pj).
; STATUS SPECIAUX DU LAP + COMPIL ;
STA40: ; reserve.
JRST ERST
STA41: ;*** MEMORY
JNNUMB A2,ERST ; yfo abolument un nb.
MOVE A5,MEM(A2) ; RECUP ADRESSE.
JUMPE A3,STA411 ; VERS GET ONLY.
JNNUMB A3,ERST
MOVE A6,MEM(A3) ; RECUP VAL.
MOVEM A6,(A5)
STA411:
MOVE A5,(A5)
JRST CRANUM
STA42: ;*** GETMEM
JNNUMB A2,ERST
MOVE A5,MEM(A2) ; RECUP NO DE TABLE.
MOVE A5,TABMEM(A5)
JRST CRANUM
STA43: ; *** ecrit un demi-mot.
; APPEL : (STATUS 43 ADRESSE VALEUR).
JNNUMB A2,ERST ; L'ADRESSE N'EST PAS UN NB.
JNNUMB A3,ERST ; LA VALEUR N'EST PAS UN NB.
MOVE A7,MEM(A2) ; RECUP L'ADRESSE.
MOVE A6,MEM(A3) ; RECUP LA VALEUR.
JNNIL A8,STA431 ; c'est une partie gauche.
HRRM A6,(A7) ; FORCE LA PARTIE DROITE.
POPJ P, ; VOILA...
STA431:
HRLM A6,(A7) ; force la partie gauche.
POPJ P, ; voila.
STA44: ; *** LODMEM entier.
SETZ A5, ; raz la valeur.
UNCONS A2,A1,A2 ; A1 <- le codop.
MOVE A6,MEM(A1) ; recup sa valeur.
LSH A6,↑D27 ; on decale, et
OR A5,A6 ; on ajoute.
UNCONS A2,A1,A2 ; recup reg 1er op.
MOVE A6,MEM(A1)
LSH A6,↑D23
OR A5,A6
UNCONS A2,A1,A2 ; recup indirection.
MOVE A6,MEM(A1)
LSH A6,↑D22
OR A5,A6
UNCONS A2,A1,A2 ; recup l'adresse.
MOVE A6,MEM(A1)
OR A5,A6
GETCAR A2,A1 ; recup index.
MOVE A6,MEM(A1)
LSH A6,↑D18
OR A5,A6
PJRST CRANUM ; cre la valeur.
TABMEM:
MEXP TABMEM,MEM,CATOM,BNUMB,PZER,BCNUM,BSTRG,BLIST
MEXP ELIST,BPILE,USTCKB,USTCKC,USTCKE,BCODEB,BCODEC,BCODEE
MEXP REENT,GARBCL,CRACAR,CRAZER,CRAONE,CRANUM
MEXP PRINT,PRIN1,$1STATUS,PRNC1,TRUTH,FALSE,VPOPJ
MEXP SPLUS,SDIFFER,STIMES,SQUO,SREM,SMIN,SMAX
MEXP SBIND,FSBIND,NSUBR,NSUBRP,ESBIND,ESCAPT
MEXP $MAPCN,$MAPC1,CMPELM,$POP,$TERPRI
MEXP $GT,$GE,$LT,$LE,SBIND1,SBIND2,SBIND3
STATAB:
MEXP STA0,STA1,STA2,STA3,STA4,STA5,STA6,STA7
MEXP STA8,STA9,STA10,STA11,STA12,STA13,STA14,STA15
MEXP STA16,STA17,STA18,STA19,STA20,STA21,STA22,STA23
MEXP STA24,STA25,STA26,STA27,STA28,STA29,STA30,STA31
MEXP STA32,STA33,STA34,STA35,STA36,STA37,STA38,STA39
MEXP STA40,STA41,STA42,STA43,STA44
STATUS:
GETCAR A4,A1 ; PETIT MACH POUR AIDER LES ROUTINES.
GETCDR A4,A3
GETCAR A3,A2
GETCDR A3,A8
GETCAR A8,A3 ; A1 <- 1ER ARG, A2 <- 2EME, A3 <- 3EME.
GETCDR A8,A8 ; A8 <- (4eme arg).
STATU2:
JUMPE A1,STA0
JNNUMB A1,ERST ; A1 # NUMERO DE STATUS
MOVE A5,MEM(A1) ; RECUP LE NUMERO.
JUMPL A5,ERST ; SI 44 < NB < 0 .
CAIL A5,55
JRST ERST
JRST @STATAB(A5) ; AIGUILLAGE.
;?!? yfodrait par la suite ne plus rien faire (i.e.
; supprimer A4 dans tous ls STATUS.
$1STATUS:: ; appel avec 1 argument.
CONSL A4,A1,NIL ; y fo une liste.
JRST STATUS
$2STATUS:: ; appel avec 2 arguments.
CONSL A4,A1,NIL ; preapre le premier doublet.
CONSL A2,A2,NIL ; prepare le 2eme doublet.
PUTCDR A4,A2 ; on accroche.
JRST STATUS ; c'est parti.
$3STATUS:: ; appel avec 3 arguments.
CONSL A4,A1,NIL ; prepare le 1er doublet.
CONSL A2,A2,NIL ; prepare le 2eme.
PUTCDR A4,A2 ; accroche.
CONSL A3,A3,NIL ; prepare le 3eme.
PUTCDR A2,A3
JRST STATUS ; voila.
; LAP : GETSYMBOL
; (GETSYMBOL at) [1SUBR]
; ramene la val du symbole specifiee
; Il n'utilise que la table du high-seg.
GETSYMBOL:
MOVE A7,[POINT 7,MEM+1(A1),13] ; saute le 1er caractere.
JSP L,CVATR0
SKIPL A6,.JBHSM+.JBHGH; adr de la table des symboles globaux.
PJRST FALSE ; elle existe pas.
GETSY1:
MOVE A7,(A6)
TLZ A7,740000 ; enleve tous els flags.
JUMPE A7,GETSY3 ; saute tous les nulls.
CAMN A5,A7 ; compar les symb.
JRST GETSY5 ; c'est cuila.
GETSY3:
AOBJP A6,.+2 ; saute la val
AOBJN A6,GETSY1 ; symbol suivant.
PJRST FALSE ; fin table.
GETSY5:
MOVE A5,1(A6) ; recup la val
PJRST CRANUM ; creat de la val.
; LAP : OPCD
; (OPCD at) [1SUBR]
; ramene la val du codop at.
DEFINE MSXBIT(P1,P2,P3,P4,P5,P6,P7,P8)<
.XCREF
SIXBIT /P1/
XLIST
SIXBIT /P2/
SIXBIT /P3/
SIXBIT /P4/
SIXBIT /P5/
SIXBIT /P6/
SIXBIT /P7/
SIXBIT /P8/
LIST
.CREF>
OPCDTB:
MSXBIT DFAD,DFSB,DFMP,DFDV,Z,Z,Z,Z
MSXBIT DMOVE,DMOVN,FIX,Z,DMOVEM,DMOVNM,FIXR,FLTR
MSXBIT UFA,DFN,FSC,IBP,ILDB,LDB,IDPB,DPB
MSXBIT FAD,FADL,FADM,FADB,FADR,FADRI,FADRM,FADRB
MSXBIT FSB,FSBL,FSBM,FSBB,FSBR,FSBRI,FSBRM,FSBRB
MSXBIT FMP,FMPL,FMPM,FMPB,FMPR,FMPRI,FMPRM,FMPRB
MSXBIT FDV,FDVL,FDVM,FDVB,FDVR,FDVRI,FDVRM,FDVRB
MSXBIT MOVE,MOVEI,MOVEM,MOVES,MOVS,MOVSI,MOVSM,MOVSS
MSXBIT MOVN,MOVNI,MOVNM,MOVNS,MOVM,MOVMI,MOVMM,MOVMS
MSXBIT IMUL,IMULI,IMULM,IMULB,MUL,MULI,MULM,MULB
MSXBIT IDIV,IDIVI,IDIVM,IDIVB,DIV,DIVI,DIVM,DIVB
MSXBIT ASH,ROT,LSH,JFFO,ASHC,ROTC,LSHC,Z
MSXBIT EXCH,BLT,AOBJP,AOBJN,JRST,JFCL,XCT,MAP
MSXBIT PUSHJ,PUSH,POP,POPJ,JSR,JSP,JSA,JRA
MSXBIT ADD,ADDI,ADDM,ADDB,SUB,SUBI,SUBM,SUBB
MSXBIT CAI,CAIL,CAIE,CAILE,CAIA,CAIGE,CAIN,CAIG
MSXBIT CAM,CAML,CAME,CAMLE,CAMA,CAMGE,CAMN,CAMG
MSXBIT JUMP,JUMPL,JUMPE,JUMPLE,JUMPA,JUMPGE,JUMPN,JUMPG
MSXBIT SKIP,SKIPL,SKIPE,SKIPLE,SKIPA,SKIPGE,SKIPN,SKIPG
MSXBIT AOJ,AOJL,AOJE,AOJLE,AOJA,AOJGE,AOJN,AOJG
MSXBIT AOS,AOSL,AOSE,AOSLE,AOSA,AOSGE,AOSN,AOSG
MSXBIT SOJ,SOJL,SOJE,SOJLE,SOJA,SOJGE,SOJN,SOJG
MSXBIT SOS,SOSL,SOSE,SOSLE,SOSA,SOSGE,SOSN,SOSG
MSXBIT SETZ,SETZI,SETZM,SETZB,AND,ANDI,ANDM,ANDB
MSXBIT ANDCA,ANDCAI,ANDCAM,ANDCAM,SETM,SETMI,SETMM,SETMB
MSXBIT ANDCM,ANDCMI,ANDCMM,ANDCMB,SETA,SETAI,SETAM,SETAB
MSXBIT XOR,XORI,XORM,XORB,IOR,IORI,IORM,IORB
MSXBIT ANDCB,ANDCBI,ANDCBM,ANDCBB,EQV,EQVI,EQVM,EQVB
MSXBIT SETCA,SETCAI,SETCAM,SETCAB,ORCA,ORCAI,ORCAM,ORCAB
MSXBIT SETCM,SETCMI,SETCMM,SETCMB,ORCM,ORCMI,ORCMM,ORCMB
MSXBIT ORCB,ORCBI,ORCBM,ORCBB,SETO,SEYOI,SETOM,SETOB
MSXBIT HLL,HLLI,HLLM,HLLS,HRL,HRLI,HRLM,HRLS
MSXBIT HLLZ,HLLZI,HLLZM,HLLZS,HRLZ,HRLZI,HRLZM,HRLZS
MSXBIT HLLO,HLLOI,HLLOM,HLLOS,HRLO,HRLOI,HRLOM,HRLOS
MSXBIT HLLE,HLLEI,HLLEM,HLLES,HRLE,HRLEI,HRLEM,HRLES
MSXBIT HRR,HRRI,HRRM,HRRS,HLR,HLRI,HLRM,HLRS
MSXBIT HRRZ,HRRZI,HRRZM,HRRZS,HLRZ,HLRZI,HLRZM,HLRZS
MSXBIT HRRO,HRROI,HRROM,HRROS,HLRO,HLROI,HLROM,HLROS
MSXBIT HRRE,HRREI,HRREM,HRRES,HLRE,HLREI,HLREM,HLRES
MSXBIT TRN,TLN,TRNE,TLNE,TRNA,TLNA,TRNN,TLNN
MSXBIT TDN,TSN,TDNE,TSNE,TDNA,TSNA,TDNN,TSNN
MSXBIT TRZ,TLZ,TRZE,TLZE,TRZA,TLZA,TRZN,TLZN
MSXBIT TDZ,TSZ,TDZE,TSZE,TDZA,TSZA,TDZN,TSZN
MSXBIT TRC,TLC,TRCE,TLCE,TRCA,TLCA,TRCN,TLCN
MSXBIT TDC,TSC,TDCE,TSCE,TDCA,TSCA,TDCN,TSCN
MSXBIT TRO,TLO,TROE,TLOE,TROA,TLOA,TRON,TLON
MSXBIT TDO,TSO,TDOE,TSOE,TDOA,TSOA,TDON,TSON
OPCDMX=.-OPCDTB
OPCD:
PUSH P,A1 ; sauve l'atome.
MOVEI A2,A.OPCD
PUSHJ P,GET ; essaied'abord un GET.
JUMPN A1,P.P ; le get a reussi.
MOVE A1,(P) ; A1 <- l'atome.
JSP L,CONVCS ; conversion en SIXBIT.
MOVSI A6,-OPCDMX ; taille de la table.
SETZ A1, ; prepare la val fausse de retour.
OPDC3:
CAME A5,OPCDTB(A6)
AOBJN A6,OPDC3 ; au suivant
JUMPGE A6,P.P ; il existait pas.
HLLI A6, ; A5 <- index courant.
MOVE A5,A6
ADDI A5,110 ; calcul vrai code.
PUSHJ P,CRANUM ; interne cette val.
EXCH A1,(P) ; A1 <- l'atome.
MOVE A2,(P) ; A2 <- la val (internee).
MOVEI A3,A.OPCD
PUSHJ P,ADDPROP
POP P,A1 ; recup la val
POPJ P,
; LAP : REGISTER
; (REGISTER n) [1SUBR] ramene le no du reg ou NIL.
REGTB:
BYTE (7)2,"R","G"
BYTE (7)2,"A","1"
BYTE (7)2,"A","2"
BYTE (7)2,"A","3"
BYTE (7)2,"A","4"
BYTE (7)2,"A","5"
BYTE (7)2,"A","6"
BYTE (7)2,"A","7"
BYTE (7)2,"A","8"
BYTE (7)2,"U","1"
BYTE (7)2,"U","2"
BYTE (7)1,"L"
BYTE (7)4,"S","T","R","G"
BYTE (7)4,"N","U","M","B"
BYTE (7)4,"F","R","E","E"
BYTE (7)1,"P"
REGMX=.-REGTB
REGISTER:
JUMPE A1,VPOPJ ; NIL est faux.
JPATOM A1,REGIS1 ; si atome litteral.
CAML A1,BSTRG
JRST FALSE ; chaine ou liste.
MOVE A5,MEM(A1) ; A5 <- val de l'argument.
CAIL A5,0 ; qui doit etre
CAILE A5,17 ; un no correct.
PJRST FALSE ; ca va pas.
POPJ P,
REGIS1:
PUSH P,A1 ; sauve le nom.
MOVEI A2,A.REGISTER
PUSHJ P,GET ; peut-etre c'est deja fait.
POP P,A2 ; recup le nom.
JUMPN A1,REGISTER ; ya quekchose.
REGIS2: ; appelle par valap.
MOVSI A5,-REGMX
MOVE A6,MEM+1(A2) ; recup le Pname du nom.
REGIS3:
CAME A6,REGTB(A5)
AOBJN A5,REGIS3
JUMPGE A5,FALSE ; la table est finie.
PUSH P,A2 ; sauve le nom.
HLLI A5, ; A5 <- indice courant.
PUSHJ P,CRANUM ; que l'on interne.
EXCH A1,(P) ; A1 <- le nom
MOVE A2,(P) ; A2 <- la val.
MOVEI A3,A.REGISTER
PUSHJ P,ADDPROP ; pour la prochaine fois.
POP P,A1 ; recup la val
POPJ P,
; LAP : VALAP
; (VALAP a) [1SUBR]
; ramene la val LAP du symbole a ou bien NIL.
;
; (DE VALAP (S)
; (COND
; ((NULL S) NIL)
; ((NUMBP S) S)
; ((LITATOM S) (OR (GET S 'VALAP)
; (AND (MEMQ (TYPEFN ADR) '(SUBR FSUBR VALAP))
; (PUT S f-val de S 'VALAP))
; (REGISTER S))))
; (T NIL)))
VALAP:
JUMPE A1,VPOPJ
JPATOM A1,VALAP1
CAML A1,BSTRG
JRST FALSE ; si chaine ou nombre.
POPJ P, ; tout nb est OK.
VALAP1:
MOVEI A2,A.VALAP
PUSH P,A1 ; sauve le nom.
PUSHJ P,GET ; Il est deja defini ?
POP P,A2 ; recup le nom.
JUMPN A1,VALAP ; re-teste la val ramenee.
HLRZ A5,MEM+5(A2) ; test le F-type.
CAIE A5,SUBR
CAIN A5,FSUBR
JRST VALAP2
CAIE A5,A.VALAP
PJRST REGIS2
VALAP2:
PUSH P,A2 ; sauve le nom.
HRRZ A5,MEM+5(A2)
PUSHJ P,CRANUM ; cre la F-val
EXCH A1,(P) ; nom
MOVE A2,(P) ; val
MOVEI A3,A.VALAP ; ind
PUSHJ P,PUT
POP P,A1
POPJ P,
; LAP : LOADCODE
; (LODCODE adr/NIL N/(N.N)/(opcd ac indir adr indx) S/NIL) [3SUBR]
; Chrge 1 instruction en memoire et actualise le pointeur.
; si adr # NIL : reinit le pointeur d'assemblage.
; si S # NIL : y fo pas vraiment charger mais ecrire le
; resultat de l'assemblage (pass 2)
; ramene toujours la val courante du point d'assemblage.
LOADCODE:
;;; traitement du 1er arg adrsse.
JPNIL A1,LOADC1 ; yen a pas.
MOVE A5,MEM(A1) ; nouvelle adresse
MOVEM A5,BCODEC ; que l'on charge.
LOADC1:
MOVE A5,BCODEC ; l'adresse actuelle
CAML A5,BCODEB ; est valide ?
CAML A5,BCODEE
JRST ERCOD ; nan !
;;; traitement chargeur
JNNIL A3,LOADP1 ; c'est pour le listeur simple.
JPLIST A3,LOADC2
;; cas N.
MOVE A6,MEM(A2) ; prend la val a charger.
JRST LOADC8
LOADC2:
UNCONS A2,A4,A2
JNNUMB A2,LOADC3
;; cas (N . N)
HRL A6,MEM(A2) ; partie gauche
HRR A6,MEM(A4) ; partie droite
JRST LOADC8 ; vers chargement de A6.
LOADC3: ;; cas (opcd ac indir adr indx)
MOVE A6,MEM(A4) ; codop
LSH A6,↑D27
JPNIL A2,LOADC8 ; ya pu rien d'autre.
UNCONS A2,A4,A2
HRRZ A7,MEM(A4) ; ac
ANDI A7,17
LSH A7,↑D23
OR A6,A7
JPNIL A2,LOADC8 ; ya pu rien d'autre.
UNCONS A2,A4,A2
HRRZ A7,MEM(A4) ; @
ANDI A7,1
LSH A7,↑D22
OR A6,A7
JPNIL A2,LOADC8 ; ya pu rien d'autre.
UNCONS A2,A4,A2
HRR A6,MEM(A4) ; adr
JPNIL A2,LOADC8 ; ya ou rien d'autre.
GETCAR A2,A4
HRRZ A7,MEM(A4) ; index
ANDI A7,17 ; masque le no du registre.
LSH A7,↑D18
OR A6,A7
LOADC8: ; chargement de A6.
MOVEM A6,(A5) ; charge le mot.
LOADC9: ; fin du LOADCODE.
AOS A5,BCODEC
JRST CRANUM ; ramene le nouveau pointeur.
LOADP1: ;;; assemblage 2eme passe.
MOVN A6,OBASE ; sauve l'ancienne base de sortie.
PUSH P,A6 ; en negatif a cose des GCs.
MOVEI A6,10 ; maintenant base octale.
MOVEM A6,OBASE
PUSH P,A3 ; sauve S.
PUSH P,A2 ; sauve N.
PUSHJ P,CRANUM ; convert le point courant.
PUSHJ P,PRIN1 ; que l'onimprime.
POP P,A2 ; recupere N
JNLIST A2,LOADP8 ; cas N simple : impr a2.
UNCONS A2,A1,A2
JNNUMB A2,LOADP3
;; cas (n . n)
MOVEI A5,↑D12
MOVEM A5,BUFOUP ; (TTAB 12)
PUSH P,A2
JRST LOADP7
LOADP3: ;; cas (opcd ac indir adr indx)
MOVEI A5,↑D8
MOVEM A5,BUFOUP ; (TTAB 8)
PUSH P,A2
PUSHJ P,PRIN1 ; impression opcd.
MOVEI A5,↑D12
MOVEM A5,BUFOUP ; (TTAB 12)
POP P,A2
UNCONS A2,A1,A2
PUSH P,A2
SKIPN A1
MOVE A1,PZER ; ya aps d'ac.
PUSHJ P,PRIN1 ; impression ac.
MOVEI A5,↑D15
MOVEM A5,BUFOUP ; (TTAB 15)
POP P,A2
UNCONS A2,A1,A2
PUSH P,A2
SKIPN A1
MOVE A1,PZER
PUSHJ P,PRIN1 ; impression @
MOVEI A5,↑D17
MOVEM A5,BUFOUP ; (TTAB 17)
POP P,A2
UNCONS A2,A1,A2
GETCAR A2,A1
SKIPN A1
MOVE A1,PZER
LOADP7:
PUSHJ P,PRIN1 ; impression indx.
POP P,A2
SKIPA A5,[EXP ↑D20]
LOADP8:
MOVEI A5,↑D12
MOVEM A5,BUFOUP ; (TTAB 12/20)
SKIPN A1,A2
MOVE A1,PZER
PUSHJ P,PRIN1
MOVEI A5,↑D30
MOVEM A5,BUFOUP ; (TTAB 30)
POP P,A1 ; recup l'instruction.
POP P,A5 ; recup la base.
MOVNM A5,OBASE
PUSHJ P,PRINT ; imprim l'instruction.
JRST LOADC9
; CMPL : :NSUBR :NSUBRP :SBIND :FSBIND
; :NSUBR LANCEMENT D'UNE N-SUBR DONT LES ARGS ONT ETE EMPILES.
; LE DERNIER ARGUMENT EST DANS A1.
; LA FONCTION DE LANCEMENT EST INDIQUEE PAR LE DERNIER
; MOT EMPILE QUI A LA FORME : XWD -1,FNT.
; :NSUBRP idem mais fait un POPJ apres.
; APPEL : JRST 0 NSUBRP.
NSUBR::
CONSL A4,A1,NIL ; CRE LE DEBUT DE LA LISTE D'ARGUMENTS.
JRST NSUBR2
NSUBR1:
CONSL A4,A5 ; CONSTRUIT LA LISTE D'ARGS.
NSUBR2:
POP P,A5 ; ELEMENT SUIVANT DE LA PILE.
TLZN A5,-1 ; C'EST LA FONCTION MARQUEE ?
JRST NSUBR1 ; NAN.
PUSH P,L ; OUI : ON PREPARE LE RETOUR DE LA
JRST (A5) ; FONCTION ET ON Y VA.
NSUBRP::
CONSL A4,A1,NIL
JRST NSBRP2
NSBRP1:
CONSL A4,A5
NSBRP2:
POP P,A5
TLZN A5,-1
JRST NSBRP1
JRST (A5)
; :SBIND EFFECTUE LE BIND D'UNE SUBR COMPILEE.
; APPEL : (JSP L :SBIND)
; (XWD 'fnt '(var1 var2 ... varN))
; DOIT EMPILER L'@ DU 'TAILRC', LES FONCTIONS COMPILEES
; FAISANT UN (POPJ P) SIMPLE POUR LES RETOURS.
;
; :FSBIND IDEM POUR LES FSUBRs COMPILEES.
FSBIND::
CONSL A4,A1,NIL ; COMPATIBILITE SUBR-FSUBR.
SBIND::
MOVE A8,L ; SAUVE L (BIND N'UTILISE PAS A8).
HRRZ A2,(A8) ; RECUP LE LISTE DES VARIABLES.
HRRO A7,P ; prepare un block LAMBDA :
; [ -1 ,, point end frame]
JSP L,BIND
HLRZ A7,(A8) ; recupere la fonction compilee.
PUSH P,A7 ; que l'on sauve pour les
; tails-recs et les co-post-recs.
PUSH P,[TAILRC] ; PREPARE LE RETOUR DE LA FNT COMPILEE.
JRST 1(A8) ; RETOUR AU CODE.
; CMPL : :SBIND1 :SBIND2
; :SBIND1 effectue le bind d'une 1SUBR compilee
; appel : (JSP L :SBIND1)
; (XWD 'fnt 'var1)
; avec dans A1 la val de l'argument.
; doit empiler TAILRC car les SUBRs font un POPJ en fin.
SBIND1::
HRRO A8,P ; prepare [ -1 ,, point end frame].
PUSH P,P$BIND ; prepare lambda-frame.
HRRZ A4,(L) ; recup l'argument.
PUSH P,A4 ; prepare [ 0 ,, var1].
GETCAR A4,A6 ; old cval1
HRLM A6,(P) ; old cval1 ,, var1
PUTCAR A4,A1 ; binding.
PUSH P,A8 ; type block lambda [-1,,point end frame].
MOVEM P,P$BIND
HLRZ A8,(L) ; recup le nom de la fonction compilee.
PUSH P,A8 ; pour les tail-recs et co-post-recs.
PUSH P,[TAILRC] ; prepare le UNBIND.
JRST 1(L) ; retour au code.
; :SBIND2 effectue la liaison d'une 2SUBR
; appel : (JSP L :SBIND2)
; (XWD 'fnt '(var1 var2))
; avec A1 <- val1 A2 <- val2
SBIND2::
HRRO A8,P ; prepare [ -1 ,, point end frame].
PUSH P,P$BIND ; prepare lambda-frame.
HRRZ A4,(L) ; A4 <- (var1 var2)
UNCONS A4,A5,A4 ; A5 <- l'argument.
PUSH P,A5 ; 0 ,, var1
GETCAR A5,A6 ; old val1
HRLM A6,(P) ; old cval ,, var1
PUTCAR A5,A1 ; bind var1
GETCAR A4,A4 ; A4 <- var2.
PUSH P,A4 ; 0 ,, var2
GETCAR A4,A6 ; old cval2
HRLM A6,(P) ; old cval ,, var2
PUTCAR A4,A2 ; bind2
PUSH P,A8 ; type block lambda [-1,,point end frame].
MOVEM P,P$BIND
HLRZ A8,(L) ; recup le nom de la fonction compilee.
PUSH P,A8 ; pour les tail-recs et co-post-recs.
PUSH P,[TAILRC] ; prepare le unbind.
JRST 1(L) ; retour au code.
; CMPL : :SBIND3 :ESBIND :PRINC1
; :SBIND3 appel : (JSP L :SBIND3)
; (XWD 'fnt '(var1 var2 var3))
; avec A1 <- val1 A2 <- val2 A3 <- val3
SBIND3::
HRRO A8,P ; prepare [ -1 ,, point end frame].
PUSH P,P$BIND ; prepare lambda-frame.
MOVE A4,(L) ; recup les vars.
UNCONS A4,A5,A4
PUSH P,A5 ; 0 ,, var1
GETCAR A5,A6
HRLM A6,(P) ; old cval1 ,, var1
PUTCAR A5,A1 ; bind var1
UNCONS A4,A5,A4
PUSH P,A5 ; 0 ,, var2
GETCAR A5,A6
HRLM A6,(P) ; old cval2 ,, var2
PUTCAR A5,A2 ; bind var2
GETCAR A4,A5
PUSH P,A5 ; 0 ,, var3
GETCAR A5,A6
HRLM A6,(P) ; old cval3 ,, var3
PUTCAR A5,A3 ; bind var3
PUSH P,A8 ; pour les tail-recs et co-post-recs.
MOVEM P,P$BIND
HLRZ A8,(L) ; recup le nom de la fonction compilee.
PUSH P,A8 ; pour les tail-recs et co-post-recs.
PUSH P,[TAILRC] ; prepare le unbind.
JRST 1(L) ; retour au code.
; ESBIND : PREPARE LA PILE POUR LES ESCAPES COMPILES.
; APPEL : JSP L,:ESBIND
; XWD @ DE LA FIN DU ESCAPE,NOM DU ESCAPE
ESBIND::
HLRZ A8,(L) ; RECUP L'@ DE FIN.
PUSH P,A8 ; POUR LE POPJ FINAL DE UNBIND.
HRRZ A2,(L) ; RECUP LE NOM DU ESCAPE.
PUSH P,A2 ; EMPILE P$NAME.
MOVEI A4,AESC ; NOUVELLE VALEUR DU NOM.
MOVSI A7,-2 ; TYPE BLOCK = -2 (ESCAPE) [-2,,0].
HRR A7,P ; prepare [ -2 ,, point end frame]
AOJA L,BIND ; ON BIND.
; :PRINC1 : APPEL DE PRINC AVEC 1 ARG.
PRNC1:
SETZ A2, ; ON PREPARE DONC A2.
JRST PRINC ; ET ON Y VA.
; CMPL : :$MAPCN :$MAPC1 :$MAPN :$MAP1
; :$MAPCN traite les MAPC utilisant des NSUBRs tres rapidement
; :$MAPC1 traite les MAPC utilisant des 1-2-3SUBRs tres rapidement
; :$MAPN traite les MAP utilisant des NSUBRs tres rapidement.
; :$MAP1 traite les MAP utilisant des 1-2-3SUBRs tres rapidement.
; (sans passer par APPLY).
; appel : (MOVE A1 larg)
; (MOVEI A2 fnt)
; (PUSHJ P :$MAPCN/:$MAPC1/:$MAPN/:$MAP1)
$MAPCN:: ;;; :MAPCN (pour les NSUBRs)
HRRZ A5,MEM+5(A2) ; sauve l'@ de lancement NSUBR.
PUSH P,A5
PUSH P,A1 ; sauve la liste d'elements.
JRST SMAPC2
SMAPC1:
UNCONS A1,A4,A1 ; element suivant.
MOVEM A1,(P) ; sauve le reste.
CONSL A4,A4,NIL ; prepare larg pour NSUBRs.
PUSHJ P,@-2(P) ; lance lA NSUBR.
MOVE A1,(P) ; restore le reste.
SMAPC2:
JPLIST A1,SMAPC1 ; ya encore des elements.
SUB P,[2,,2] ; restore liste et l'@ de lancement.
POPJ P, ; c'est fini.
$MAPC1:: ;;; :MAPC1 (pour les 1SUBRs)
HRRZ A5,MEM+5(A2) ; sauve l'@ de lancement de la fonction.
PUSH P,A5
PUSH P,A1 ; sauve la liste d'argument.
JRST SMAPC4
SMAPC3:
UNCONS A1,A1,A3 ; element suivant de A1.
MOVEM A3,(P) ; sauve le reste.
SETZB A2,A3 ; pour les 2-3SUBRs.
PUSHJ P,@-1(P) ; on lance la 1SUBR.
MOVE A1,(P) ; puis on recupere le reste de la liste.
SMAPC4:
JPLIST A1,SMAPC3 ; ya encore des elements.
SUB P,[2,,2] ; depile le reste et l'@ de lancement.
POPJ P, ; c'est fini.
$MAPN:: ;;; :MAPN (pour les NSUBRs)
HRRZ A5,MEM+5(A2) ; sauve l'@ de lancement NSUBR.
PUSH P,A5
PUSH P,A1 ; sauve la liste d'elements.
JRST SMAP2
SMAP1:
GETCDR A1,A4 ; element suivant.
MOVEM A4,(P) ; sauve le reste.
CONSL A4,A1,NIL ; prepare larg pour NSUBRs.
PUSHJ P,@-2(P) ; lance lA NSUBR.
MOVE A1,(P) ; restore le reste.
SMAP2:
JPLIST A1,SMAP1 ; ya encore des elements.
SUB P,[2,,2] ; restore liste et l'@ de lancement.
POPJ P, ; c'est fini.
$MAP1:: ;;; :MAP1 (pour les 1SUBRs)
HRRZ A5,MEM+5(A2) ; sauve l'@ de lancement de la fonction.
PUSH P,A5
PUSH P,A1 ; sauve la liste d'argument.
JRST SMAP4
SMAP3:
GETCDR A1,A3 ; elements suivants dans A3.
MOVEM A3,(P) ; que l'on sauve.
SETZB A2,A3 ; pour les 2-3SUBRs.
PUSHJ P,@-1(P) ; on lance la 1SUBR.
MOVE A1,(P) ; puis on recupere le reste de la liste.
SMAP4:
JPLIST A1,SMAP3 ; ya encore des elements.
SUB P,[2,,2] ; depile le reste et l'@ de lancement.
POPJ P, ; c'est fini.
; FONCTIONS TRES SPECIALES : DDT BREAK STOP . ;
; APPEL DE DDT
; RETOUR PAR : JRST RDDT$X OU RDDT$X OU RDDT$G
ADDT:
HRRZ A5,.JBDDT ; recup l'@ de lancement de DDT.
JUMPN A5,(A5) ; s'il a ete charge on y va.
RDDT=<JRST .>
POPJ P,
; (BREAK S1 ... SN) - FSUBR -
BREAK:
PUSHJ P,EPROGN
PUSH P,A1 ; SAUVE VAL BREAK.
PUSHJ P,OUTBUF
MOVE A6,[POINT 7,[BYTE (7)17,"*","*"," "," "
ASCIZ /ENTER BREAK : /],6]
PUSHJ P,PRBPN
MOVE A1,(P)
PUSHJ P,PRINT
BREAK1:
MOVEI A1,A.TOPLV
SETZ A4,
PUSHJ P,APPLY
CAME A1,(P) ; C'EST LA VAL BREAK ?
JRST BREAK1 ; NAN.
PUSHJ P,OUTBUF
MOVE A6,[POINT 7,[BYTE (7)17,"*","*"," "," "
ASCIZ /EXIT BREAK : /],6]
PUSHJ P,PRBPN
POP P,A1
JRST PRINT
; (STOP) - SUBR -
STOP:
RESET ; pour revenir sur la page 0.
OUTSTR [ASCIZ /Bye/]
EXIT
; LLIT : fin de l'interprete .
$$LITT::
SUBTTL LITTERAUX
PRINTX /14-LITTERAUX/
IFN %%LLIT,<
LIT>
$$END::
END START